lisp/cedet/semantic/analyze/refs.el

   1 ;;; semantic/analyze/refs.el --- Analysis of the references between tags.
   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 ;; Analyze the references between tags.
  25 ;;
  26 ;; The original purpose of these analysis is to provide a way to jump
  27 ;; between a prototype and implementation.
  28 ;;
  29 ;; Finding all prototype/impl matches is hard because you have to search
  30 ;; through the entire set of allowed databases to capture all possible
  31 ;; refs.  The core analysis class stores basic starting point, and then
  32 ;; entire raw search data, which is expensive to calculate.
  33 ;;
  34 ;; Once the raw data is available, queries for impl, prototype, or
  35 ;; perhaps other things become cheap.
  36
  37 (require 'semantic)
  38 (require 'semantic/analyze)
  39 (require 'semantic/db-find)
  40 (eval-when-compile (require 'semantic/find))
  41
  42 (declare-function data-debug-new-buffer "data-debug")
  43 (declare-function data-debug-insert-object-slots "eieio-datadebug")
  44 (declare-function semantic-momentary-highlight-tag "semantic/decorate")
  45
  46 ;;; Code:
  47 (defclass semantic-analyze-references ()
  48   ((tag :initarg :tag
  49         :type semantic-tag
  50         :documentation
  51         "The starting TAG we are providing references analysis for.")
  52    (tagdb :initarg :tagdb
  53           :documentation
  54           "The database that tag can be found in.")
  55    (scope :initarg :scope
  56           :documentation "A Scope object.")
  57    (rawsearchdata :initarg :rawsearchdata
  58                   :documentation
  59                   "The raw search data for TAG's name across all databases.")
  60    ;; Note: Should I cache queried data here?  I expect that searching
  61    ;; through rawsearchdata will be super-fast, so why bother?
  62    )
  63   "Class containing data from a semantic analysis.")
  64
  65 (define-overloadable-function semantic-analyze-tag-references (tag &optional db)
  66   "Analyze the references for TAG.
  67 Returns a class with information about TAG.
  68
  69 Optional argument DB is a database.  It will be used to help
  70 locate TAG.
  71
  72 Use `semantic-analyze-current-tag' to debug this fcn.")
  73
  74 (defun semantic-analyze-tag-references-default (tag &optional db)
  75   "Analyze the references for TAG.
  76 Returns a class with information about TAG.
  77
  78 Optional argument DB is a database.  It will be used to help
  79 locate TAG.
  80
  81 Use `semantic-analyze-current-tag' to debug this fcn."
  82   (when (not (semantic-tag-p tag))  (signal 'wrong-type-argument (list 'semantic-tag-p tag)))
  83   (let ((allhits nil)
  84         (scope nil)
  85         )
  86     (save-excursion
  87       (semantic-go-to-tag tag db)
  88       (setq scope (semantic-calculate-scope))
  89
  90       (setq allhits (semantic--analyze-refs-full-lookup tag scope))
  91
  92       (semantic-analyze-references (semantic-tag-name tag)
  93                                     :tag tag
  94                                     :tagdb db
  95                                     :scope scope
  96                                     :rawsearchdata allhits)
  97       )))
  98
  99 ;;; METHODS
 100 ;;
 101 ;; These accessor methods will calculate the useful bits from the context, and cache values
 102 ;; into the context.
 103 (defmethod semantic-analyze-refs-impl ((refs semantic-analyze-references) &optional in-buffer)
 104   "Return the implementations derived in the reference analyzer REFS.
 105 Optional argument IN-BUFFER indicates that the returned tag should be in an active buffer."
 106   (let ((allhits (oref refs rawsearchdata))
 107         (impl nil)
 108         )
 109     (semanticdb-find-result-mapc
 110      (lambda (T DB)
 111        "Examine T in the database DB, and sont it."
 112        (let* ((ans (semanticdb-normalize-one-tag DB T))
 113               (aT (cdr ans))
 114               (aDB (car ans))
 115               )
 116          (when (not (semantic-tag-prototype-p aT))
 117            (when in-buffer (save-excursion (semantic-go-to-tag aT aDB)))
 118            (push aT impl))))
 119      allhits)
 120     impl))
 121
 122 (defmethod semantic-analyze-refs-proto ((refs semantic-analyze-references) &optional in-buffer)
 123   "Return the prototypes derived in the reference analyzer REFS.
 124 Optional argument IN-BUFFER indicates that the returned tag should be in an active buffer."
 125   (let ((allhits (oref refs rawsearchdata))
 126         (proto nil))
 127     (semanticdb-find-result-mapc
 128      (lambda (T DB)
 129        "Examine T in the database DB, and sort it."
 130        (let* ((ans (semanticdb-normalize-one-tag DB T))
 131               (aT (cdr ans))
 132               (aDB (car ans))
 133               )
 134          (when (semantic-tag-prototype-p aT)
 135            (when in-buffer (save-excursion (semantic-go-to-tag aT aDB)))
 136            (push aT proto))))
 137      allhits)
 138     proto))
 139
 140 ;;; LOOKUP
 141 ;;
 142 (defun semantic--analyze-refs-full-lookup (tag scope)
 143   "Perform a full lookup for all occurances of TAG in the current project.
 144 TAG should be the tag currently under point.
 145 PARENT is the list of tags that are parents to TAG by
 146 containment, as opposed to reference."
 147   (if (not (oref scope parents))
 148       ;; If this tag has some named parent, but is not
 149       (semantic--analyze-refs-full-lookup-simple tag)
 150
 151     ;; We have some sort of lineage we need to consider when we do
 152     ;; our side lookup of tags.
 153     (semantic--analyze-refs-full-lookup-with-parents tag scope)
 154     ))
 155
 156 (defun semantic--analyze-refs-find-child-in-find-results (find-results name class)
 157   "Find in FIND-RESULT a tag NAME which is a child of a tag in FIND-RESULTS.
 158 CLASS is the class of the tag that ought to be returned."
 159   (let ((ans nil)
 160         (subans nil))
 161     ;; Loop over each segment of the find results.
 162     (dolist (FDB find-results)
 163       (setq subans nil)
 164       ;; Loop over each tag in the find results.
 165       (dolist (T (cdr FDB))
 166         ;; For each tag, get the children.
 167         (let* ((chil (semantic-tag-type-members T))
 168                (match (semantic-find-tags-by-name name chil)))
 169           ;; Go over the matches, looking for matching tag class.
 170           (dolist (M match)
 171             (when (semantic-tag-of-class-p M class)
 172               (push M subans)))))
 173       ;; Store current matches into a new find results.
 174       (when subans
 175         (push (cons (car FDB) subans) ans))
 176       )
 177     ans))
 178
 179 (defun semantic--analyze-refs-find-tags-with-parent (find-results parents)
 180   "Find in FIND-RESULTS all tags with PARNTS.
 181 NAME is the name of the tag needing finding.
 182 PARENTS is a list of names."
 183   (let ((ans nil))
 184     (semanticdb-find-result-mapc
 185      (lambda (tag db)
 186        (let* ((p (semantic-tag-named-parent tag))
 187               (ps (when (stringp p)
 188                     (semantic-analyze-split-name p))))
 189          (when (stringp ps) (setq ps (list ps)))
 190          (when (and ps (equal ps parents))
 191            ;; We could optimize this, but it seems unlikely.
 192            (push (list db tag) ans))
 193          ))
 194      find-results)
 195     ans))
 196
 197 (defun semantic--analyze-refs-full-lookup-with-parents (tag scope)
 198   "Perform a lookup for all occurances of TAG based on TAG's SCOPE.
 199 TAG should be the tag currently under point."
 200   (let* ((classmatch (semantic-tag-class tag))
 201          (plist (mapcar (lambda (T) (semantic-tag-name T)) (oref scope parents)))
 202          ;; The first item in the parent list
 203          (name (car plist))
 204          ;; Stuff from the simple list.
 205          (simple (semantic--analyze-refs-full-lookup-simple tag t))
 206          ;; Find all hits for the first parent name.
 207          (brute (semanticdb-find-tags-collector
 208                  (lambda (table tags)
 209                    (semanticdb-find-tags-by-name-method table name tags)
 210                    )
 211                  nil nil t))
 212          ;; Prime the answer.
 213          (answer (semantic--analyze-refs-find-tags-with-parent simple plist))
 214          )
 215     ;; First parent is already search to initialize "brute".
 216     (setq plist (cdr plist))
 217     ;; Go through the list of parents, and try to find matches.
 218     ;; As we cycle through plist, for each level look for NAME,
 219     ;; and compare the named-parent, and also dive into the next item of
 220     ;; plist.
 221     (while (and plist brute)
 222
 223       ;; Find direct matches
 224       (let* ((direct (semantic--analyze-refs-find-child-in-find-results
 225                       brute (semantic-tag-name tag) classmatch))
 226              (pdirect (semantic--analyze-refs-find-tags-with-parent
 227                        direct plist)))
 228         (setq answer (append pdirect answer)))
 229
 230       ;; The next set of search items.
 231       (setq brute (semantic--analyze-refs-find-child-in-find-results
 232                    brute (car plist) 'type))
 233
 234       (setq plist (cdr plist)))
 235
 236     ;; Brute now has the children from the very last match.
 237     (let* ((direct (semantic--analyze-refs-find-child-in-find-results
 238                     brute (semantic-tag-name tag) classmatch))
 239            )
 240       (setq answer (append direct answer)))
 241
 242     answer))
 243
 244 (defun semantic--analyze-refs-full-lookup-simple (tag &optional noerror)
 245   "Perform a simple  lookup for occurances of TAG in the current project.
 246 TAG should be the tag currently under point.
 247 Optional NOERROR means don't throw errors on failure to find something.
 248 This only compares the tag name, and does not infer any matches in namespaces,
 249 or parts of some other data structure.
 250 Only works for tags in the global namespace."
 251   (let* ((name (semantic-tag-name tag))
 252          (brute (semanticdb-find-tags-collector
 253                  (lambda (table tags)
 254                    (semanticdb-find-tags-by-name-method table name tags)
 255                    )
 256                  nil nil t))
 257          )
 258
 259         (when (and (not brute) (not noerror))
 260           ;; An error, because tag under point ought to be found.
 261           (error "Cannot find any references to %s in wide search" name))
 262
 263         (let* ((classmatch (semantic-tag-class tag))
 264                (RES
 265                 (semanticdb-find-tags-collector
 266                  (lambda (table tags)
 267                    (semantic-find-tags-by-class classmatch tags)
 268                    ;; @todo - Add parent check also.
 269                    )
 270                  brute nil)))
 271
 272           (when (and (not RES) (not noerror))
 273             (error "Cannot find any definitions for %s in wide search"
 274                    (semantic-tag-name tag)))
 275
 276           ;; Return the matching tags and databases.
 277           RES)))
 278
 279
 280 ;;; USER COMMANDS
 281 ;;
 282 ;;;###autoload
 283 (defun semantic-analyze-current-tag ()
 284   "Analyze the tag under point."
 285   (interactive)
 286   (let* ((tag (semantic-current-tag))
 287          (start (current-time))
 288          (sac (semantic-analyze-tag-references tag))
 289          (end (current-time))
 290          )
 291     (message "Analysis took %.2f seconds." (semantic-elapsed-time start end))
 292     (if sac
 293         (progn
 294           (require 'eieio-datadebug)
 295           (data-debug-new-buffer "*Analyzer Reference ADEBUG*")
 296           (data-debug-insert-object-slots sac "]"))
 297       (message "No Context to analyze here."))))
 298
 299 ;;;###autoload
 300 (defun semantic-analyze-proto-impl-toggle ()
 301   "Toggle between the implementation, and a prototype of tag under point."
 302   (interactive)
 303   (require 'semantic/decorate)
 304   (semantic-fetch-tags)
 305   (let* ((tag (semantic-current-tag))
 306          (sar (if tag
 307                   (semantic-analyze-tag-references tag)
 308                 (error "Point must be in a declaration")))
 309          (target (if (semantic-tag-prototype-p tag)
 310                      (car (semantic-analyze-refs-impl sar t))
 311                    (car (semantic-analyze-refs-proto sar t))))
 312          )
 313
 314     (when (not target)
 315       (error "Could not find suitable %s"
 316              (if (semantic-tag-prototype-p tag) "implementation" "prototype")))
 317
 318     (push-mark)
 319     (semantic-go-to-tag target)
 320     (switch-to-buffer (current-buffer))
 321     (semantic-momentary-highlight-tag target))
 322   )
 323
 324
 325
 326 (provide 'semantic/analyze/refs)
 327
 328 ;; Local variables:
 329 ;; generated-autoload-file: "../loaddefs.el"
 330 ;; generated-autoload-feature: semantic/loaddefs
 331 ;; generated-autoload-load-name: "semantic/analyze/refs"
 332 ;; End:
 333
 334 ;;; semantic/analyze/refs.el ends here