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