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

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