cgit.sxemacs.org Git - packages/blob - xemacs-packages/semantic/semantic-adebug.el

   1 ;;; semantic-adebug.el --- Semantic Application Debugger
   2
   3 ;; Copyright (C) 2007 Eric M. Ludlam
   4
   5 ;; Author: Eric M. Ludlam <eric@siege-engine.com>
   6 ;; X-RCS: $Id: semantic-adebug.el,v 1.1 2007-11-26 15:10:32 michaels Exp $
   7
   8 ;; This program is free software; you can redistribute it and/or
   9 ;; modify it under the terms of the GNU General Public License as
  10 ;; published by the Free Software Foundation; either version 2, or (at
  11 ;; your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful, but
  14 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 ;; General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program; see the file COPYING.  If not, write to
  20 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  21 ;; Boston, MA 02110-1301, USA.
  22
  23 ;;; Commentary:
  24 ;;
  25 ;; Semantic datastructure debugger for semantic applications.
  26 ;;
  27 ;; Goals:
  28 ;;
  29 ;; Inspect all known details of a TAG in a buffer.
  30 ;;
  31 ;; Analyze the list of active semantic databases, and the tags therin.
  32 ;;
  33 ;; Allow interactive navigation of the analysis process, tags, etc.
  34 ;;
  35 ;; Navigate to the correct function for debugging.
  36
  37 (require 'font-lock)
  38 (require 'semantic-analyze)
  39
  40 ;;; Code:
  41
  42 ;;; GENERIC STUFF
  43 ;;
  44 ;;;###autoload
  45 (defun semantic-adebug-insert-property-list (proplist prefix &optional parent)
  46   "Insert the property list PROPLIST.
  47 Each line starts with PREFIX.
  48 The attributes belong to the tag PARENT."
  49   (while proplist
  50     (let ((pretext (concat (symbol-name (car proplist)) " : ")))
  51       (semantic-adebug-insert-thing (car (cdr proplist))
  52                                     prefix
  53                                     pretext
  54                                     parent))
  55     (setq proplist (cdr (cdr proplist)))))
  56
  57 ;;; TAG STUFF
  58 ;;
  59 (defun semantic-adebug-insert-tag-parts (tag prefix &optional parent)
  60   "Insert all the parts of TAG.
  61 PREFIX specifies what to insert at the start of each line.
  62 PARENT specifires any parent tag."
  63   (semantic-adebug-insert-thing (semantic-tag-name tag)
  64                                 prefix
  65                                 "Name: "
  66                                 parent)
  67   (insert prefix "Class: '" (format "%S" (semantic-tag-class tag)) "\n")
  68   (when (semantic-tag-with-position-p tag)
  69     (let ((ol (semantic-tag-overlay tag))
  70           (file (semantic-tag-file-name tag))
  71           (start (semantic-tag-start tag))
  72           (end (semantic-tag-end tag))
  73           )
  74       (insert prefix "Position: "
  75               (if (and (numberp start) (numberp end))
  76                   (format "%d -> %d in " start end)
  77                 "")
  78               (if file (file-name-nondirectory file) "unknown-file")
  79               (if (semantic-overlay-p ol)
  80                   " <live tag>"
  81                 "")
  82               "\n")
  83       (semantic-adebug-insert-thing ol prefix
  84                                     "Position Data: "
  85                                     parent)
  86       ))
  87   (let ((attrprefix (concat (make-string (length prefix) ? ) "# ")))
  88     (insert prefix "Attributes:\n")
  89     (semantic-adebug-insert-property-list
  90      (semantic-tag-attributes tag) attrprefix tag)
  91     (insert prefix "Properties:\n")
  92     (semantic-adebug-insert-property-list
  93      (semantic-tag-properties tag) attrprefix tag)
  94     )
  95
  96   )
  97
  98 (defun semantic-adebug-insert-tag-parts-from-point (point)
  99   "Call `semantic-adebug-insert-tag-parts' based on text properties at POINT."
 100   (let ((tag (get-text-property point 'adebug))
 101         (parent (get-text-property point 'adebug-parent))
 102         (indent (get-text-property point 'adebug-indent))
 103         start end
 104         )
 105     (end-of-line)
 106     (setq start (point))
 107     (forward-char 1)
 108     (semantic-adebug-insert-tag-parts tag
 109                                       (concat (make-string indent ? )
 110                                               "| ")
 111                                       parent)
 112     (setq end (point))
 113     (goto-char start)
 114     ))
 115
 116 (defun semantic-adebug-insert-tag (tag prefix prebuttontext &optional parent)
 117   "Insert TAG into the current buffer at the current point.
 118 PREFIX specifies text to insert in front of TAG.
 119 Optional PARENT is the parent tag containing TAG.
 120 Add text properties needed to allow tag expansion later."
 121   (let ((start (point))
 122         (end nil)
 123         (str (semantic-format-tag-uml-abbreviate tag parent t))
 124         (tip (semantic-format-tag-prototype tag parent t))
 125         )
 126     (insert prefix prebuttontext str "\n")
 127     (setq end (point))
 128     (put-text-property start end 'adebug tag)
 129     (put-text-property start end 'adebug-parent parent)
 130     (put-text-property start end 'adebug-indent(length prefix))
 131     (put-text-property start end 'adebug-prefix prefix)
 132     (put-text-property start end 'help-echo tip)
 133     (put-text-property start end 'adebug-function
 134                        'semantic-adebug-insert-tag-parts-from-point)
 135
 136     ))
 137
 138 ;;; TAG LISTS
 139 ;;
 140 (defun semantic-adebug-insert-tag-list (taglist prefix &optional parent)
 141   "Insert the tag list TAGLIST with PREFIX.
 142 Optional argument PARENT specifies the part of TAGLIST."
 143   (while taglist
 144     (if (semantic-tag-p (car taglist))
 145         (semantic-adebug-insert-tag (car taglist) prefix "" parent)
 146       (semantic-adebug-insert-thing (car taglist) prefix "" parent))
 147     (setq taglist (cdr taglist))))
 148
 149 (defun semantic-adebug-insert-taglist-from-point (point)
 150   "Insert the taglist found at the taglist button at POINT."
 151   (let ((taglist (get-text-property point 'adebug))
 152         (parent (get-text-property point 'adebug-parent))
 153         (indent (get-text-property point 'adebug-indent))
 154         start end
 155         )
 156     (end-of-line)
 157     (setq start (point))
 158     (forward-char 1)
 159     (semantic-adebug-insert-tag-list taglist
 160                                      (concat (make-string indent ? )
 161                                              "* ")
 162                                      parent)
 163     (setq end (point))
 164     (goto-char start)
 165
 166   ))
 167
 168 (defun semantic-adebug-insert-tag-list-button (taglist prefix prebuttontext &optional parent)
 169   "Insert a single summary of a TAGLIST.
 170 PREFIX is the text that preceeds the button.
 171 PREBUTTONTEXT is some text between PREFIX and the taglist button.
 172 PARENT is the tag that represents the parent of all the tags."
 173   (let ((start (point))
 174         (end nil)
 175         (str (format "#<TAG LIST: %d entries>" (length taglist)))
 176         (tip nil))
 177     (insert prefix prebuttontext str)
 178     (setq end (point))
 179     (put-text-property (- end (length str)) end 'face 'font-lock-function-name-face)
 180     (put-text-property start end 'adebug taglist)
 181     (put-text-property start end 'adebug-parent parent)
 182     (put-text-property start end 'adebug-indent(length prefix))
 183     (put-text-property start end 'adebug-prefix prefix)
 184     (put-text-property start end 'help-echo tip)
 185     (put-text-property start end 'adebug-function
 186                        'semantic-adebug-insert-taglist-from-point)
 187     (insert "\n")
 188     ))
 189
 190 ;;; SEMANTICDB FIND RESULTS
 191 ;;
 192 (defun semantic-adebug-insert-find-results (findres prefix)
 193   "Insert the find results FINDRES with PREFIX."
 194   ;; ( (DBOBJ TAG TAG TAG) (DBOBJ TAG TAG TAG) ... )
 195   (let ((cnt 1))
 196     (while findres
 197       (let* ((dbhit (car findres))
 198              (db (car dbhit))
 199              (tags (cdr dbhit)))
 200         (semantic-adebug-insert-thing db prefix (format "DB %d: " cnt))
 201         (semantic-adebug-insert-thing tags prefix (format "HITS %d: " cnt))
 202         )
 203       (setq findres (cdr findres)
 204             cnt (1+ cnt)))))
 205
 206 (defun semantic-adebug-insert-find-results-from-point (point)
 207   "Insert the find results found at the find results button at POINT."
 208   (let ((findres (get-text-property point 'adebug))
 209         (indent (get-text-property point 'adebug-indent))
 210         start end
 211         )
 212     (end-of-line)
 213     (setq start (point))
 214     (forward-char 1)
 215     (semantic-adebug-insert-find-results findres
 216                                          (concat (make-string indent ? )
 217                                                  "!* ")
 218                                          )
 219     (setq end (point))
 220     (goto-char start)
 221   ))
 222
 223 (defun semantic-adebug-insert-find-results-button (findres prefix prebuttontext)
 224   "Insert a single summary of a find results FINDRES.
 225 PREFIX is the text that preceeds the button.
 226 PREBUTTONTEXT is some text between prefix and the find results button."
 227   (let ((start (point))
 228         (end nil)
 229         (str (semanticdb-find-result-prin1-to-string findres))
 230         (tip nil))
 231     (insert prefix prebuttontext str)
 232     (setq end (point))
 233     (put-text-property (- end (length str)) end 'face 'font-lock-function-name-face)
 234     (put-text-property start end 'adebug findres)
 235     (put-text-property start end 'adebug-indent(length prefix))
 236     (put-text-property start end 'adebug-prefix prefix)
 237     (put-text-property start end 'help-echo tip)
 238     (put-text-property start end 'adebug-function
 239                        'semantic-adebug-insert-taglist-from-point)
 240     (insert "\n")
 241     ))
 242
 243 ;;; overlays
 244 ;;
 245 (defun semantic-adebug-insert-overlay-props (overlay prefix)
 246   "Insert all the parts of OVERLAY.
 247 PREFIX specifies what to insert at the start of each line."
 248   (let ((attrprefix (concat (make-string (length prefix) ? ) "# "))
 249         (proplist (semantic-overlay-properties overlay)))
 250     (semantic-adebug-insert-property-list
 251      proplist attrprefix)
 252     )
 253   )
 254
 255 (defun semantic-adebug-insert-overlay-from-point (point)
 256   "Insert the overlay found at the overlay button at POINT."
 257   (let ((overlay (get-text-property point 'adebug))
 258         (indent (get-text-property point 'adebug-indent))
 259         start end
 260         )
 261     (end-of-line)
 262     (setq start (point))
 263     (forward-char 1)
 264     (semantic-adebug-insert-overlay-props overlay
 265                                           (concat (make-string indent ? )
 266                                                   "| "))
 267     (setq end (point))
 268     (goto-char start)
 269     ))
 270
 271 (defun semantic-adebug-insert-overlay-button (overlay prefix prebuttontext)
 272   "Insert a button representing OVERLAY.
 273 PREFIX is the text that preceeds the button.
 274 PREBUTTONTEXT is some text between prefix and the overlay button."
 275   (let ((start (point))
 276         (end nil)
 277         (str (format "%s" overlay))
 278         (tip nil))
 279     (insert prefix prebuttontext str)
 280     (setq end (point))
 281     (put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
 282     (put-text-property start end 'adebug overlay)
 283     (put-text-property start end 'adebug-indent(length prefix))
 284     (put-text-property start end 'adebug-prefix prefix)
 285     (put-text-property start end 'help-echo tip)
 286     (put-text-property start end 'adebug-function
 287                        'semantic-adebug-insert-overlay-from-point)
 288     (insert "\n")
 289     )
 290   )
 291
 292 ;;; overlay list
 293 ;;
 294 (defun semantic-adebug-insert-overlay-list (overlaylist prefix)
 295   "Insert all the parts of OVERLAYLIST.
 296 PREFIX specifies what to insert at the start of each line."
 297   (while overlaylist
 298     (semantic-adebug-insert-overlay-button (car overlaylist)
 299                                            prefix
 300                                            "")
 301     (setq overlaylist (cdr overlaylist))))
 302
 303 (defun semantic-adebug-insert-overlay-list-from-point (point)
 304   "Insert the overlay found at the overlay list button at POINT."
 305   (let ((overlaylist (get-text-property point 'adebug))
 306         (indent (get-text-property point 'adebug-indent))
 307         start end
 308         )
 309     (end-of-line)
 310     (setq start (point))
 311     (forward-char 1)
 312     (semantic-adebug-insert-overlay-list overlaylist
 313                                           (concat (make-string indent ? )
 314                                                   "* "))
 315     (setq end (point))
 316     (goto-char start)
 317     ))
 318
 319 (defun semantic-adebug-insert-overlay-list-button (overlaylist
 320                                                    prefix
 321                                                    prebuttontext)
 322   "Insert a button representing OVERLAYLIST.
 323 PREFIX is the text that preceeds the button.
 324 PREBUTTONTEXT is some text between prefix and the overlay list button."
 325   (let ((start (point))
 326         (end nil)
 327         (str (format "#<overlay list: %d entries>" (length overlaylist)))
 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 'adebug overlaylist)
 333     (put-text-property start end 'adebug-indent(length prefix))
 334     (put-text-property start end 'adebug-prefix prefix)
 335     (put-text-property start end 'help-echo tip)
 336     (put-text-property start end 'adebug-function
 337                        'semantic-adebug-insert-overlay-list-from-point)
 338     (insert "\n")
 339     )
 340   )
 341
 342 ;;; Rings
 343 ;;
 344 ;; A ring (like kill-ring, or whatever.)
 345 (defun semantic-adebug-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 ((elts (ring-elements ring))
 349         )
 350     (while elts
 351       (semantic-adebug-insert-thing (car elts) prefix "")
 352       (setq elts (cdr elts)))))
 353
 354 (defun semantic-adebug-insert-ring-items-from-point (point)
 355   "Insert the ring found at the ring button at POINT."
 356   (let ((ring (get-text-property point 'adebug))
 357         (indent (get-text-property point 'adebug-indent))
 358         start end
 359         )
 360     (end-of-line)
 361     (setq start (point))
 362     (forward-char 1)
 363     (semantic-adebug-insert-ring-contents ring
 364                                           (concat (make-string indent ? )
 365                                                   "} "))
 366     (setq end (point))
 367     (goto-char start)
 368     ))
 369
 370 (defun semantic-adebug-insert-ring-button (ring
 371                                            prefix
 372                                            prebuttontext)
 373   "Insert a button representing RING.
 374 PREFIX is the text that preceeds the button.
 375 PREBUTTONTEXT is some text between prefix and the stuff list button."
 376   (let* ((start (point))
 377          (end nil)
 378          (str (format "#<RING: %d>" (ring-size ring)))
 379          (ringthing (ring-ref ring 0))
 380          (tip (format "Ring max-size %d, length %d.  Full of: %S"
 381                       (ring-size ring)
 382                       (ring-length ring)
 383                       (cond ((stringp ringthing)
 384                              "strings")
 385                             ((semantic-tag-p ringthing)
 386                              "tags")
 387                             ((object-p ringthing)
 388                              "eieio objects")
 389                             ((listp ringthing)
 390                              "List of somethin'")
 391                             (t "stuff"))))
 392          )
 393     (insert prefix prebuttontext str)
 394     (setq end (point))
 395     (put-text-property (- end (length str)) end 'face 'font-lock-type-face)
 396     (put-text-property start end 'adebug ring)
 397     (put-text-property start end 'adebug-indent(length prefix))
 398     (put-text-property start end 'adebug-prefix prefix)
 399     (put-text-property start end 'help-echo tip)
 400     (put-text-property start end 'adebug-function
 401                        'semantic-adebug-insert-ring-items-from-point)
 402     (insert "\n")
 403     )
 404   )
 405
 406 ;;; list of stuff
 407 ;;
 408 ;; just a list.  random stuff inside.
 409 ;;;###autoload
 410 (defun semantic-adebug-insert-stuff-list (stufflist prefix)
 411   "Insert all the parts of STUFFLIST.
 412 PREFIX specifies what to insert at the start of each line."
 413   (while stufflist
 414     (semantic-adebug-insert-thing
 415      ;; Some lists may put a value in the CDR
 416      (if (listp stufflist) (car stufflist) stufflist)
 417      prefix
 418      "")
 419     (setq stufflist
 420           (if (listp stufflist)
 421               (cdr stufflist)
 422             nil))))
 423
 424 (defun semantic-adebug-insert-stuff-list-from-point (point)
 425   "Insert the stuff found at the stuff list button at POINT."
 426   (let ((stufflist (get-text-property point 'adebug))
 427         (indent (get-text-property point 'adebug-indent))
 428         start end
 429         )
 430     (end-of-line)
 431     (setq start (point))
 432     (forward-char 1)
 433     (semantic-adebug-insert-stuff-list stufflist
 434                                        (concat (make-string indent ? )
 435                                                "> "))
 436     (setq end (point))
 437     (goto-char start)
 438     ))
 439
 440 (defun semantic-adebug-insert-stuff-list-button (stufflist
 441                                                  prefix
 442                                                  prebuttontext)
 443   "Insert a button representing STUFFLIST.
 444 PREFIX is the text that preceeds the button.
 445 PREBUTTONTEXT is some text between prefix and the stuff list button."
 446   (let ((start (point))
 447         (end nil)
 448         (str
 449          (condition-case nil
 450              (format "#<list o' stuff: %d entries>" (length stufflist))
 451            (error "#<list o' stuff>")))
 452         (tip (format "%s" stufflist)))
 453     (insert prefix prebuttontext str)
 454     (setq end (point))
 455     (put-text-property (- end (length str)) end 'face 'font-lock-variable-name-face)
 456     (put-text-property start end 'adebug stufflist)
 457     (put-text-property start end 'adebug-indent(length prefix))
 458     (put-text-property start end 'adebug-prefix prefix)
 459     (put-text-property start end 'help-echo tip)
 460     (put-text-property start end 'adebug-function
 461                        'semantic-adebug-insert-stuff-list-from-point)
 462     (insert "\n")
 463     )
 464   )
 465
 466 ;;; simple thing
 467 (defun semantic-adebug-insert-simple-thing (thing prefix prebuttontext face)
 468   "Insert one simple THING with a face.
 469 PREFIX is the text that preceeds the button.
 470 PREBUTTONTEXT is some text between prefix and the thing.
 471 FACE is the face to use."
 472   (insert prefix prebuttontext)
 473   (let ((start (point))
 474         (end nil))
 475     (insert (format "%s" thing))
 476     (setq end (point))
 477     (insert "\n" )
 478     (put-text-property start end 'face face)
 479     ))
 480
 481 ;; uber insert method
 482 (defun semantic-adebug-insert-thing (thing prefix prebuttontext &optional parent)
 483   "Insert THING with PREFIX.
 484 PREBUTTONTEXT is some text to insert between prefix and the thing
 485 that is not included in the indentation calculation of any children.
 486 If PARENT is non-nil, it is somehow related as a parent to thing."
 487   (cond
 488    ;; eieio object
 489    ((object-p thing)
 490     (semantic-adebug-insert-object-button
 491      thing prefix prebuttontext))
 492
 493    ;; tag
 494    ((semantic-tag-p thing)
 495     (semantic-adebug-insert-tag
 496      thing prefix prebuttontext parent))
 497
 498    ;; taglist
 499    ((and (listp thing) (semantic-tag-p (car thing)))
 500     (semantic-adebug-insert-tag-list-button
 501      thing prefix prebuttontext parent))
 502
 503    ;; find results
 504    ((semanticdb-find-results-p thing)
 505     (semantic-adebug-insert-find-results-button
 506      thing prefix prebuttontext))
 507
 508    ;; Overlay
 509    ((semantic-overlay-p thing)
 510     (semantic-adebug-insert-overlay-button thing prefix prebuttontext)
 511     )
 512    ((and (listp thing) (semantic-overlay-p (car thing)))
 513     (semantic-adebug-insert-overlay-list-button thing prefix prebuttontext)
 514     )
 515
 516    ;; String
 517    ((stringp thing)
 518     (semantic-adebug-insert-simple-thing thing prefix prebuttontext
 519                                          'font-lock-string-face)
 520     )
 521
 522    ;; Symbol
 523    ((symbolp thing)
 524     (cond ((fboundp thing)
 525            (semantic-adebug-insert-simple-thing
 526             thing prefix (concat prebuttontext "#'")
 527             'font-lock-function-name-face)
 528            )
 529           ((boundp thing)
 530            (semantic-adebug-insert-simple-thing
 531             thing prefix (concat prebuttontext "'")
 532             'font-lock-variable-name-face))
 533           (t
 534            (semantic-adebug-insert-simple-thing
 535             thing prefix (concat prebuttontext "'")
 536             nil)
 537            )
 538           ))
 539
 540    ;; Ring
 541    ((ring-p thing)
 542     (semantic-adebug-insert-ring-button thing prefix prebuttontext))
 543
 544    ;; List of stuff
 545    ((listp thing)
 546     (semantic-adebug-insert-stuff-list-button thing prefix prebuttontext))
 547
 548    (t
 549     (insert prefix prebuttontext (format "%S" thing) "\n" ))
 550    )
 551   )
 552
 553 ;;; MAJOR MODE
 554 ;;
 555 ;; The Adebug major mode provides an interactive space to explore
 556 ;; the current state of semantic's parsing and analysis
 557 ;;
 558 (defgroup semantic-adebug nil
 559   "semantic-adebug group."
 560   :group 'langauges)
 561
 562 (defvar semantic-adebug-mode-syntax-table
 563   (let ((table (make-syntax-table (standard-syntax-table))))
 564     (modify-syntax-entry ?\; ". 12"  table) ;; SEMI, Comment start ;;
 565     (modify-syntax-entry ?\n ">"     table) ;; Comment end
 566     (modify-syntax-entry ?\" "\""    table) ;; String
 567     (modify-syntax-entry ?\- "_"     table) ;; Symbol
 568     (modify-syntax-entry ?\\ "\\"    table) ;; Quote
 569     (modify-syntax-entry ?\` "'"     table) ;; Prefix ` (backquote)
 570     (modify-syntax-entry ?\' "'"     table) ;; Prefix ' (quote)
 571     (modify-syntax-entry ?\, "'"     table) ;; Prefix , (comma)
 572
 573     table)
 574   "Syntax table used in semantic-adebug macro buffers.")
 575
 576 (defvar semantic-adebug-map
 577   (let ((km (make-sparse-keymap)))
 578     (define-key km [mouse-2] 'semantic-adebug-expand-or-contract-mouse)
 579     (define-key km " " 'semantic-adebug-expand-or-contract)
 580     (define-key km "n" 'semantic-adebug-next)
 581     (define-key km "p" 'semantic-adebug-prev)
 582     (define-key km "N" 'semantic-adebug-next-expando)
 583     (define-key km "P" 'semantic-adebug-prev-expando)
 584     km)
 585   "Keymap used in semantic-adebug.")
 586
 587 (defcustom semantic-adebug-mode-hook nil
 588   "*Hook run when semantic-adebug starts."
 589   :group 'semantic-adebug
 590   :type 'hook)
 591
 592 ;;;###autoload
 593 (defun semantic-adebug-mode ()
 594   "Major-mode for the Analyzer debugger.
 595
 596 \\{semantic-adebug-map}"
 597   (interactive)
 598   (kill-all-local-variables)
 599   (setq major-mode 'semantic-adebug-mode
 600         mode-name "SEMANTIC-ADEBUG"
 601         comment-start ";;"
 602         comment-end "")
 603   (set (make-local-variable 'comment-start-skip)
 604        "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
 605   (set-syntax-table semantic-adebug-mode-syntax-table)
 606   (use-local-map semantic-adebug-map)
 607   (run-hooks 'semantic-adebug-hook)
 608   )
 609
 610 ;;;###autoload
 611 (defun semantic-adebug-new-buffer (name)
 612   "Create a new adebug buffer with NAME."
 613   (let ((b (get-buffer-create name)))
 614     (switch-to-buffer b)
 615     (set-buffer b)
 616     (erase-buffer)
 617     (semantic-adebug-mode)
 618     b))
 619
 620 ;;; Adebug mode commands
 621 ;;
 622 (defun semantic-adebug-next ()
 623   "Go to the next line in the ADebug buffer."
 624   (interactive)
 625   (forward-line 1)
 626   (beginning-of-line)
 627   (skip-chars-forward " *-><[]" (point-at-eol)))
 628
 629 (defun semantic-adebug-prev ()
 630   "Go to the next line in the ADebug buffer."
 631   (interactive)
 632   (forward-line -1)
 633   (beginning-of-line)
 634   (skip-chars-forward " *-><[]" (point-at-eol)))
 635
 636 (defun semantic-adebug-next-expando ()
 637   "Go to the next line in the ADebug buffer.
 638 Contract the current line (if open) and expand the line
 639 we move to."
 640   (interactive)
 641   (semantic-adebug-contract-current-line)
 642   (semantic-adebug-next)
 643   (semantic-adebug-expand-current-line)
 644   )
 645
 646 (defun semantic-adebug-prev-expando ()
 647   "Go to the previous line in the ADebug buffer.
 648 Contract the current line (if open) and expand the line
 649 we move to."
 650   (interactive)
 651   (semantic-adebug-contract-current-line)
 652   (semantic-adebug-prev)
 653   (semantic-adebug-expand-current-line)
 654   )
 655
 656 (defun semantic-adebug-current-line-expanded-p ()
 657   "Return non-nil if the current line is expanded."
 658   (let ((ti (current-indentation))
 659         (ni (condition-case nil
 660                 (save-excursion
 661                   (end-of-line)
 662                   (forward-char 1)
 663                   (current-indentation))
 664               (error 0))))
 665     (> ni ti)))
 666
 667 (defun semantic-adebug-expand-current-line ()
 668   "Expand the current line (if possible).
 669 Do nothing if already expanded."
 670   (when (not (semantic-adebug-current-line-expanded-p))
 671     ;; If the next line is the same or less indentation, expand.
 672     (let ((fcn (get-text-property (point) 'adebug-function)))
 673       (when fcn
 674         (funcall fcn (point))
 675         (beginning-of-line)
 676         ))))
 677
 678 (defun semantic-adebug-contract-current-line ()
 679   "Contract the current line (if possible).
 680 Do nothing if already expanded."
 681   (when (and (semantic-adebug-current-line-expanded-p)
 682              ;; Don't contract if the current line is not expandable.
 683              (get-text-property (point) 'adebug-function))
 684     (let ((ti (current-indentation))
 685           )
 686       ;; If next indentation is larger, collapse.
 687       (end-of-line)
 688       (forward-char 1)
 689       (let ((start (point))
 690             (end nil))
 691         (condition-case nil
 692             (progn
 693               ;; Keep checking indentation
 694               (while (or (> (current-indentation) ti)
 695                          (looking-at "^\\s-*$"))
 696                 (end-of-line)
 697                 (forward-char 1))
 698               (setq end (point))
 699               )
 700           (error (setq end (point-max))))
 701         (delete-region start end)
 702         (forward-char -1)
 703         (beginning-of-line)))))
 704
 705 (defun semantic-adebug-expand-or-contract ()
 706   "Expand or contract anything at the current point."
 707   (interactive)
 708   (if (semantic-adebug-current-line-expanded-p)
 709       (semantic-adebug-contract-current-line)
 710     (semantic-adebug-expand-current-line))
 711   (skip-chars-forward " *-><[]" (point-at-eol)))
 712
 713 (defun semantic-adebug-expand-or-contract-mouse (e)
 714   "Expand or contract anything at event E."
 715   (interactive "e")
 716   (goto-char (posn-point (event-start e)))
 717   (semantic-adebug-expand-or-contract)
 718   )
 719
 720 ;;; DEBUG COMMANDS
 721 ;;
 722 ;; Various commands to output aspects of the current semantic environment.
 723 ;;;###autoload
 724 (defun semantic-adebug-bovinate ()
 725   "The same as `bovinate'. Display the results in a debug buffer."
 726   (interactive)
 727   (let* ((start (current-time))
 728          (out (semantic-fetch-tags))
 729          (end (current-time))
 730          (ab (semantic-adebug-new-buffer (concat "*"
 731                                                  (buffer-name)
 732                                                  " ADEBUG*")))
 733          )
 734     (message "Retrieving tags took %.2f seconds."
 735              (semantic-elapsed-time start end))
 736
 737     (semantic-adebug-insert-tag-list out "* "))
 738   )
 739
 740 ;;;###autoload
 741 (defun semantic-adebug-searchdb (regex)
 742   "Search the semanticdb for REGEX for the current buffer.
 743 Display the results as a debug list."
 744   (interactive "sSymbol Regex: ")
 745   (let ((start (current-time))
 746         (fr (semanticdb-find-tags-by-name-regexp regex))
 747         (end (current-time))
 748         (ab (semantic-adebug-new-buffer (concat "*SEMANTICDB SEARCH: "
 749                                                 regex
 750                                                 " ADEBUG*"))))
 751     (message "Search of tags took %.2f seconds."
 752              (semantic-elapsed-time start end))
 753
 754     (semantic-adebug-insert-find-results fr "*")))
 755
 756 ;;;###autoload
 757 (defun semantic-adebug-analyze ()
 758   "Perform `semantic-analyze-current-context'.
 759 Display the results as a debug list."
 760   (interactive)
 761   (let ((start (current-time))
 762         (ctxt (semantic-analyze-current-context))
 763         (end (current-time))
 764         (ab nil))
 765     (message "Analysis  took %.2f seconds."
 766              (semantic-elapsed-time start end))
 767     (if ctxt
 768         (progn
 769           (setq ab (semantic-adebug-new-buffer "*Analyzer ADEBUG*"))
 770           (semantic-adebug-insert-object-fields ctxt "]"))
 771       (message "No Context to analyze here."))))
 772
 773 ;;;###autoload
 774 (defun semantic-adebug-edebug-expr (expr)
 775   "Dump out the contets of some expression EXPR in edebug with adebug."
 776   (interactive "sExpression: ")
 777   (let ((v (eval (read expr)))
 778         (ab nil))
 779     (if (not v)
 780         (message "Expression %s is nil." expr)
 781       (setq ab (semantic-adebug-new-buffer "*expression ADEBUG*"))
 782       (semantic-adebug-insert-thing v "?" "")
 783       )))
 784
 785
 786 (provide 'semantic-adebug)
 787
 788 ;;; semantic-adebug.el ends here