lisp/cedet/semantic/analyze/debug.el

   1 ;;; semantic/analyze/debug.el --- Debug the analyzer
   2
   3 ;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23 ;;
  24 ;; Provide a top-order debugging tool for figuring out what's going on with
  25 ;; smart completion and analyzer mode.
  26
  27 (require 'semantic)
  28 (require 'semantic/analyze)
  29 (require 'semantic/analyze/complete)
  30 (require 'semantic/db-typecache)
  31
  32 ;; For semantic-find-tags-by-class:
  33 (eval-when-compile (require 'semantic/find))
  34
  35 (declare-function ede-get-locator-object "ede/files")
  36
  37 ;;; Code:
  38
  39 (defun semantic-analyze-debug-assist ()
  40   "Debug semantic analysis at the current point."
  41   (interactive)
  42   (let ((actualfcn (fetch-overload 'semantic-analyze-current-context))
  43         (ctxt (semantic-analyze-current-context))
  44         )
  45     ;; What to show.
  46     (if actualfcn
  47         (message "Mode %s does not use the default analyzer."
  48                  major-mode)
  49       ;; Debug our context.
  50       )
  51     (or (semantic-analyzer-debug-test-local-context)
  52         (and ctxt (semantic-analyzer-debug-found-prefix ctxt))
  53         )
  54
  55     ))
  56
  57 (defun semantic-analyzer-debug-found-prefix (ctxt)
  58   "Debug the prefix found by the analyzer output CTXT."
  59   (let* ((pf (oref ctxt prefix))
  60          (pft (oref ctxt prefixtypes))
  61          (idx 0)
  62          (stop nil)
  63          (comp (condition-case nil
  64                    (semantic-analyze-possible-completions ctxt)
  65                  (error nil)))
  66          )
  67     (while (and (nth idx pf) (not stop))
  68       (let ((pentry (nth idx pf))
  69             (ptentry (nth idx pft)))
  70         (if (or (stringp pentry) (not ptentry))
  71             ;; Found someting ok.  stop
  72             (setq stop t)
  73           (setq idx (1+ idx)))))
  74     ;; We found the first non-tag entry.  What is the situation?
  75     (cond
  76      ((and (eq idx 0) (stringp (car pf)))
  77       ;; First part, we couldn't find it.
  78       (semantic-analyzer-debug-global-symbol ctxt (car pf) comp))
  79      ((not (nth (1- idx) pft)) ;; idx can't be 0 here.
  80       ;; The previous entry failed to have an identifiable data
  81       ;; type, which is a global search.
  82       (semantic-analyzer-debug-missing-datatype ctxt idx comp))
  83      ((and (nth (1- idx) pft) (stringp (nth idx pf)))
  84       ;; Non-first search, didn't find string in known data type.
  85       (semantic-analyzer-debug-missing-innertype ctxt idx comp))
  86      (t
  87       ;; Things are ok?
  88       (message "Things look ok."))
  89     )))
  90
  91 (defun semantic-analyzer-debug-global-symbol (ctxt prefix comp)
  92   "Debug why we can't find the first entry in the CTXT PREFIX.
  93 Argument COMP are possible completions here."
  94   (let ((tab semanticdb-current-table)
  95         (finderr nil)
  96         (origbuf (current-buffer))
  97         )
  98     (with-output-to-temp-buffer (help-buffer)
  99       (with-current-buffer standard-output
 100         (princ "Unable to find prefix ")
 101         (princ prefix)
 102         (princ ".\n\n")
 103
 104         ;; NOTE: This line is copied from semantic-analyze-current-context.
 105         ;;       You will need to update both places.
 106         (condition-case err
 107             (with-current-buffer origbuf
 108               (let* ((position (or (cdr-safe (oref ctxt bounds)) (point)))
 109                      (prefixtypes nil) ; Used as type return
 110                      (scope (semantic-calculate-scope position))
 111                      )
 112                 (semantic-analyze-find-tag-sequence
 113                  (list prefix "") scope 'prefixtypes)
 114                 )
 115               )
 116           (error (setq finderr err)))
 117
 118         (if finderr
 119             (progn
 120               (princ "The prefix lookup code threw the following error:\n  ")
 121               (prin1 finderr)
 122               (princ "\n\nTo debug this error you can do this:
 123   M-x toggle-debug-on-error RET
 124 and then re-run the debug analyzer.\n")
 125               )
 126           ;; No find error, just not found
 127           (princ "The prefix ")
 128           (princ prefix)
 129           (princ " could not be found in the local scope,
 130 nor in any search tables.\n")
 131           )
 132         (princ "\n")
 133
 134         ;; Describe local scope, and why we might not be able to
 135         ;; find it.
 136         (semantic-analyzer-debug-describe-scope ctxt)
 137
 138         (semantic-analyzer-debug-show-completions comp)
 139
 140         (princ "When Semantic cannot find a symbol, it could be because the include
 141 path was setup incorrectly.\n")
 142
 143         (semantic-analyzer-debug-insert-include-summary tab)
 144
 145         ))
 146     (semantic-analyzer-debug-add-buttons)
 147     ))
 148
 149 (defun semantic-analyzer-debug-missing-datatype (ctxt idx comp)
 150   "Debug why we can't find a datatype entry for CTXT prefix at IDX.
 151 Argument COMP are possible completions here."
 152   (let* ((prefixitem (nth idx (oref ctxt prefix)))
 153          (dt (nth (1- idx) (oref ctxt prefixtypes)))
 154          (tt (semantic-tag-type prefixitem))
 155          (tab semanticdb-current-table)
 156          )
 157     (when dt (error "Missing Datatype debugger is confused"))
 158     (with-output-to-temp-buffer (help-buffer)
 159       (with-current-buffer standard-output
 160         (princ "Unable to find datatype for: \"")
 161         (princ (semantic-format-tag-prototype prefixitem))
 162         (princ "\".
 163 Declared type is: ")
 164         (when (semantic-tag-p tt)
 165           (semantic-analyzer-debug-insert-tag tt)
 166           (princ "\nRaw data type is: "))
 167         (princ (format "%S" tt))
 168         (princ "
 169
 170 Semantic could not find this data type in any of its global tables.
 171
 172 Semantic locates datatypes through either the local scope, or the global
 173 typecache.
 174 ")
 175
 176         ;; Describe local scope, and why we might not be able to
 177         ;; find it.
 178         (semantic-analyzer-debug-describe-scope ctxt '(type))
 179
 180         ;; Describe the typecache.
 181         (princ "\nSemantic creates and maintains a type cache for each buffer.
 182 If the type is a global type, then it should appear in they typecache.
 183 To examine the typecache, type:
 184
 185   M-x semanticdb-typecache-dump RET
 186
 187 Current typecache Statistics:\n")
 188         (princ (format "   %4d types global in this file\n   %4d types from includes.\n"
 189                        (length (semanticdb-typecache-file-tags tab))
 190                        (length (semanticdb-typecache-include-tags tab))))
 191
 192         (princ "\nIf the datatype is not in the typecache, then your include
 193 path may be incorrect.  ")
 194
 195         (semantic-analyzer-debug-insert-include-summary tab)
 196
 197         ;; End with-buffer
 198         ))
 199     (semantic-analyzer-debug-add-buttons)
 200     ))
 201
 202 (defun semantic-analyzer-debug-missing-innertype (ctxt idx comp)
 203   "Debug why we can't find an entry for CTXT prefix at IDX for known type.
 204 We need to see if we have possible completions against the entry before
 205 being too vocal about it.
 206 Argument COMP are possible completions here."
 207   (let* ((prefixitem (nth idx (oref ctxt prefix)))
 208          (prevprefix (nth (1- idx) (oref ctxt prefix)))
 209          (dt (nth (1- idx) (oref ctxt prefixtypes)))
 210          (desired-type (semantic-analyze-type-constraint ctxt))
 211          (orig-buffer (current-buffer))
 212          (ots (semantic-analyze-tag-type prevprefix
 213                                          (oref ctxt scope)
 214                                          t ; Don't deref
 215                                          ))
 216          )
 217     (when (not dt) (error "Missing Innertype debugger is confused"))
 218     (with-output-to-temp-buffer (help-buffer)
 219       (with-current-buffer standard-output
 220         (princ "Cannot find prefix \"")
 221         (princ prefixitem)
 222         (princ "\" in datatype:
 223   ")
 224         (semantic-analyzer-debug-insert-tag dt)
 225         (princ "\n")
 226
 227         (cond
 228          ;; Any language with a namespace.
 229          ((string= (semantic-tag-type dt) "namespace")
 230           (princ "Semantic may not have found all possible namespaces with
 231 the name ")
 232           (princ (semantic-tag-name dt))
 233           (princ ".  You can debug the entire typecache, including merged namespaces
 234 with the command:
 235
 236   M-x semanticdb-typecache-dump RET")
 237           )
 238
 239          ;; @todo - external declarations??
 240          (nil
 241           nil)
 242
 243          ;; A generic explanation
 244          (t
 245           (princ "\nSemantic has found the datatype ")
 246           (semantic-analyzer-debug-insert-tag dt)
 247           (if (or (not (semantic-equivalent-tag-p ots dt))
 248                   (not (with-current-buffer orig-buffer
 249                          (car (semantic-analyze-dereference-metatype
 250                           ots (oref ctxt scope))))))
 251               (let ((lasttype ots)
 252                     (nexttype (with-current-buffer orig-buffer
 253                                 (car (semantic-analyze-dereference-metatype
 254                                  ots (oref ctxt scope))))))
 255                 (if (eq nexttype lasttype)
 256                     (princ "\n  [ Debugger error trying to help with metatypes ]")
 257
 258                   (if (eq ots dt)
 259                       (princ "\nwhich is a metatype")
 260                     (princ "\nwhich is derived from metatype ")
 261                     (semantic-analyzer-debug-insert-tag lasttype)))
 262
 263                 (princ ".\nThe Metatype stack is:\n")
 264                 (princ "   ")
 265                 (semantic-analyzer-debug-insert-tag lasttype)
 266                 (princ "\n")
 267                 (while (and nexttype
 268                             (not (eq nexttype lasttype)))
 269                   (princ "   ")
 270                   (semantic-analyzer-debug-insert-tag nexttype)
 271                   (princ "\n")
 272                   (setq lasttype nexttype
 273                         nexttype
 274                         (with-current-buffer orig-buffer
 275                           (car (semantic-analyze-dereference-metatype
 276                            nexttype (oref ctxt scope)))))
 277                   )
 278                 (when (not nexttype)
 279                   (princ "   nil\n\n")
 280                   (princ
 281                    "Last metatype is nil.  This means that semantic cannot derive
 282 the list of members because the type referred to cannot be found.\n")
 283                   )
 284                 )
 285             (princ "\nand its list of members.")
 286
 287             (if (not comp)
 288                 (progn
 289                   (princ "  Semantic does not know what
 290 possible completions there are for \"")
 291                   (princ prefixitem)
 292                   (princ "\".  Examine the known
 293 members below for more."))
 294               (princ "  Semantic knows of some
 295 possible completions for \"")
 296               (princ prefixitem)
 297               (princ "\".")))
 298           )
 299          ;; end cond
 300          )
 301
 302         (princ "\n")
 303         (semantic-analyzer-debug-show-completions comp)
 304
 305         (princ "\nKnown members of ")
 306         (princ (semantic-tag-name dt))
 307         (princ ":\n")
 308         (dolist (M (semantic-tag-type-members dt))
 309           (princ "  ")
 310           ;;(princ (semantic-format-tag-prototype M))
 311           (semantic-analyzer-debug-insert-tag M)
 312           (princ "\n"))
 313
 314         ;; This doesn't refer to in-type completions.
 315         ;;(semantic-analyzer-debug-global-miss-text prefixitem)
 316
 317         ;; More explanation
 318         (when desired-type
 319           (princ "\nWhen there are known members that would make good completion
 320 candidates that are not in the completion list, then the most likely
 321 cause is a type constraint.  Semantic has determined that there is a
 322 type constraint looking for the type ")
 323           (if (semantic-tag-p desired-type)
 324               (semantic-analyzer-debug-insert-tag desired-type)
 325             (princ (format "%S" desired-type)))
 326           (princ "."))
 327         ))
 328     (semantic-analyzer-debug-add-buttons)
 329
 330     ))
 331
 332
 333 (defun semantic-analyzer-debug-test-local-context ()
 334   "Test the local context parsed from the file."
 335   (let* ((prefixandbounds (semantic-ctxt-current-symbol-and-bounds (point)))
 336          (prefix (car prefixandbounds))
 337          (bounds (nth 2 prefixandbounds))
 338          )
 339     (when (and (or (not prefixandbounds)
 340                    (not prefix)
 341                    (not bounds))
 342                )
 343       (with-output-to-temp-buffer (help-buffer)
 344         (with-current-buffer standard-output
 345           (princ "Local Context Parser Failed.
 346
 347 If this is unexpected, then there is likely a bug in the Semantic
 348 local context parser.
 349
 350 Consider debugging the function ")
 351           (let ((lcf (fetch-overload 'semantic-ctxt-current-symbol-and-bounds)))
 352             (if lcf
 353                 (princ (symbol-name lcf))
 354               (princ "semantic-ctxt-current-symbol-and-bounds,
 355 or implementing a version specific to ")
 356               (princ (symbol-name major-mode))
 357               )
 358             (princ ".\n"))
 359           (semantic-analyzer-debug-add-buttons)
 360         t)))
 361     ))
 362
 363 ;;; General Inserters with help
 364 ;;
 365 (defun semantic-analyzer-debug-show-completions (comp)
 366   "Show the completion list COMP."
 367   (if (not comp)
 368       (princ "\nNo known possible completions.\n")
 369
 370     (princ "\nPossible completions are:\n")
 371     (dolist (C comp)
 372       (princ "  ")
 373       (cond ((stringp C)
 374              (princ C)
 375              )
 376             ((semantic-tag-p C)
 377              (semantic-analyzer-debug-insert-tag C)))
 378       (princ "\n"))
 379     (princ "\n")))
 380
 381 (defvar semantic-dependency-system-include-path)
 382
 383 (defun semantic-analyzer-debug-insert-include-summary (table)
 384   "Display a summary of includes for the semanticdb TABLE."
 385   (require 'semantic/dep)
 386   (semantic-fetch-tags)
 387   (let ((inc (semantic-find-tags-by-class 'include table))
 388         ;;(path (semanticdb-find-test-translate-path-no-loading))
 389         (unk
 390          (with-current-buffer (semanticdb-get-buffer table)
 391            semanticdb-find-lost-includes))
 392         (ip
 393          (with-current-buffer (semanticdb-get-buffer table)
 394            semantic-dependency-system-include-path))
 395         (edeobj
 396          (with-current-buffer (semanticdb-get-buffer table)
 397            (and (boundp 'ede-object)
 398                 ede-object)))
 399         (edeproj
 400          (with-current-buffer (semanticdb-get-buffer table)
 401            (and (boundp 'ede-object-project)
 402                 ede-object-project))))
 403
 404     (princ "\n\nInclude Path Summary:")
 405     (when edeobj
 406         (princ "\n\nThis file's project include search is handled by the EDE object:\n")
 407         (princ "  Buffer Target:  ")
 408         (princ (object-print edeobj))
 409         (princ "\n")
 410         (when (not (eq edeobj edeproj))
 411           (princ "  Buffer Project: ")
 412           (princ (object-print edeproj))
 413           (princ "\n"))
 414         (when edeproj
 415           (let ((loc (ede-get-locator-object edeproj)))
 416             (princ "  Backup Locator: ")
 417             (princ (object-print loc))
 418             (princ "\n")))
 419         )
 420
 421     (princ "\n\nThe system include path is:\n")
 422     (dolist (dir ip)
 423       (princ "  ")
 424       (princ dir)
 425       (princ "\n"))
 426
 427     (princ "\n\nInclude Summary: ")
 428     (princ (semanticdb-full-filename table))
 429     (princ "\n\n")
 430     (princ (format "%s contains %d includes.\n"
 431                    (file-name-nondirectory
 432                     (semanticdb-full-filename table))
 433                    (length inc)))
 434     (let ((ok 0)
 435           (unknown 0)
 436           (unparsed 0)
 437           (all 0))
 438       (dolist (i inc)
 439         (let* ((fileinner (semantic-dependency-tag-file i))
 440                (tableinner (when fileinner
 441                              (semanticdb-file-table-object fileinner t))))
 442           (cond ((not fileinner)
 443                  (setq unknown (1+ unknown)))
 444                 ((number-or-marker-p (oref tableinner pointmax))
 445                  (setq ok (1+ ok)))
 446                 (t
 447                  (setq unparsed (1+ unparsed))))))
 448       (setq all (+ ok unknown unparsed))
 449       (when (not (= 0 all))
 450         (princ (format "   Unknown Includes:  %d\n" unknown))
 451         (princ (format "   Unparsed Includes: %d\n" unparsed))
 452         (princ (format "   Parsed Includes:   %d\n" ok)))
 453       )
 454
 455     ;; Unknowns...
 456     (if unk
 457         (progn
 458           (princ "\nA likely cause of an unfound tag is missing include files.")
 459           (semantic-analyzer-debug-insert-tag-list
 460            "The following includes were not found" unk)
 461
 462           (princ "\nYou can fix the include path for ")
 463           (princ (symbol-name (oref table major-mode)))
 464           (princ " by using this function:
 465
 466 M-x semantic-customize-system-include-path RET
 467
 468 which customizes the mode specific variable for the mode-local
 469 variable `semantic-dependency-system-include-path'.")
 470           )
 471
 472       (princ "\n No unknown includes.\n"))
 473     ))
 474
 475 (defun semantic-analyzer-debug-describe-scope (ctxt &optional classconstraint)
 476   "Describe the scope in CTXT for finding a global symbol.
 477 Optional argument CLASSCONSTRAINT says to output to tags of that class."
 478   (let* ((scope (oref ctxt :scope))
 479          (parents (oref scope parents))
 480          (cc (or classconstraint (oref ctxt prefixclass)))
 481          )
 482     (princ "\nLocal Scope Information:")
 483     (princ "\n * Tag Class Constraint against SCOPE: ")
 484     (princ (format "%S" classconstraint))
 485
 486     (if parents
 487         (semantic-analyzer-debug-insert-tag-list
 488          " >> Known parent types with possible in scope symbols"
 489          parents)
 490       (princ "\n * No known parents in current scope."))
 491
 492     (let ((si (semantic-analyze-tags-of-class-list
 493                (oref scope scope) cc))
 494           (lv (semantic-analyze-tags-of-class-list
 495                (oref scope localvar) cc))
 496           )
 497       (if si
 498           (semantic-analyzer-debug-insert-tag-list
 499            " >> Known symbols within the current scope"
 500            si)
 501         (princ "\n * No known symbols currently in scope."))
 502
 503       (if lv
 504           (semantic-analyzer-debug-insert-tag-list
 505            " >> Known symbols that are declared locally"
 506            lv)
 507         (princ "\n * No known symbols declared locally."))
 508       )
 509     )
 510   )
 511
 512 (defun semantic-analyzer-debug-global-miss-text (name-in)
 513   "Use 'princ' to show text describing not finding symbol NAME-IN.
 514 NAME is the name of the unfound symbol."
 515   (let ((name (cond ((stringp name-in)
 516                      name-in)
 517                     ((semantic-tag-p name-in)
 518                      (semantic-format-tag-name name-in))
 519                     (t (format "%S" name-in)))))
 520     (when (not (string= name ""))
 521       (princ "\nIf ")
 522       (princ name)
 523       (princ " is a local variable, argument, or symbol in some
 524 namespace or class exposed via scoping statements, then it should
 525 appear in the scope.
 526
 527 Debugging the scope can be done with:
 528   M-x semantic-calculate-scope RET
 529
 530 If the prefix is a global symbol, in an included file, then
 531 your search path may be incomplete.
 532 "))))
 533
 534 ;;; Utils
 535 ;;
 536 (defun semantic-analyzer-debug-insert-tag-list (text taglist)
 537   "Prefixing with TEXT, dump TAGLIST in a help buffer."
 538   (princ "\n") (princ text) (princ ":\n")
 539
 540   (dolist (M taglist)
 541     (princ "  ")
 542     ;;(princ (semantic-format-tag-prototype M))
 543     (semantic-analyzer-debug-insert-tag M)
 544     (princ "\n"))
 545   )
 546
 547 (defun semantic-analyzer-debug-insert-tag (tag &optional parent)
 548   "Display a TAG by name, with possible jumpitude.
 549 PARENT is a possible parent (by nesting) tag."
 550   (let ((str (semantic-format-tag-prototype tag parent)))
 551     (if (and (semantic-tag-with-position-p tag)
 552              (semantic-tag-file-name tag))
 553         (insert-button str
 554                        'mouse-face 'custom-button-pressed-face
 555                        'tag tag
 556                        'action
 557                        `(lambda (button)
 558                           (let ((buff nil)
 559                                 (pnt nil))
 560                             (save-excursion
 561                               (semantic-go-to-tag
 562                                (button-get button 'tag))
 563                               (setq buff (current-buffer))
 564                               (setq pnt (point)))
 565                             (if (get-buffer-window buff)
 566                                 (select-window (get-buffer-window buff))
 567                               (pop-to-buffer buff t))
 568                             (goto-char pnt)
 569                             (pulse-line-hook-function)))
 570                        )
 571       (princ "\"")
 572       (princ str)
 573       (princ "\""))
 574     ))
 575
 576 (defvar semantic-analyzer-debug-orig nil
 577   "The originating buffer for a help button.")
 578
 579 (defun semantic-analyzer-debug-add-buttons ()
 580   "Add push-buttons to the *Help* buffer.
 581 Look for key expressions, and add push-buttons near them."
 582   (let ((orig-buffer (make-marker)))
 583     (set-marker orig-buffer (point) (current-buffer))
 584     ;; Get a buffer ready.
 585     (with-current-buffer "*Help*"
 586       (toggle-read-only -1)
 587       (goto-char (point-min))
 588       (set (make-local-variable 'semantic-analyzer-debug-orig) orig-buffer)
 589       ;; First, add do-in buttons to recommendations.
 590       (while (re-search-forward "^\\s-*M-x \\(\\(\\w\\|\\s_\\)+\\) " nil t)
 591         (let ((fcn (match-string 1)))
 592           (when (not (fboundp (intern-soft fcn)))
 593             (error "Help Err: Can't find %s" fcn))
 594           (end-of-line)
 595           (insert "   ")
 596           (insert-button "[ Do It ]"
 597                          'mouse-face 'custom-button-pressed-face
 598                          'do-fcn fcn
 599                          'action `(lambda (arg)
 600                                     (let ((M semantic-analyzer-debug-orig))
 601                                       (set-buffer (marker-buffer M))
 602                                       (goto-char M))
 603                                     (call-interactively (quote ,(intern-soft fcn))))
 604                          )
 605           ))
 606       ;; Do something else?
 607
 608       ;; Clean up the mess
 609       (toggle-read-only 1)
 610       (set-buffer-modified-p nil)
 611       )))
 612
 613 (provide 'semantic/analyze/debug)
 614
 615 ;; arch-tag: 943db1e5-47e6-4bec-9989-78ebfadf0358
 616 ;;; semantic/analyze/debug.el ends here