Commit | Line | Data |
---|---|---|
a6de3d1a CY |
1 | ;;; semantic/analyze/refs.el --- Analysis of the references between tags. |
2 | ||
114f9c96 | 3 | ;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc. |
a6de3d1a CY |
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 | ||
1fe1547a CY |
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 | ||
a6de3d1a CY |
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) | |
9bf6c65c | 143 | "Perform a full lookup for all occurrences of TAG in the current project. |
a6de3d1a CY |
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) | |
9bf6c65c | 198 | "Perform a lookup for all occurrences of TAG based on TAG's SCOPE. |
a6de3d1a CY |
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) | |
9bf6c65c | 245 | "Perform a simple lookup for occurrences of TAG in the current project. |
a6de3d1a CY |
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 | ;; | |
1fe1547a | 282 | ;;;###autoload |
a6de3d1a CY |
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 | |
1fe1547a | 294 | (require 'eieio-datadebug) |
a6de3d1a CY |
295 | (data-debug-new-buffer "*Analyzer Reference ADEBUG*") |
296 | (data-debug-insert-object-slots sac "]")) | |
297 | (message "No Context to analyze here.")))) | |
298 | ||
1fe1547a | 299 | ;;;###autoload |
a6de3d1a CY |
300 | (defun semantic-analyze-proto-impl-toggle () |
301 | "Toggle between the implementation, and a prototype of tag under point." | |
302 | (interactive) | |
1fe1547a | 303 | (require 'semantic/decorate) |
a6de3d1a CY |
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 | ||
a6de3d1a CY |
324 | (provide 'semantic/analyze/refs) |
325 | ||
1fe1547a CY |
326 | ;; Local variables: |
327 | ;; generated-autoload-file: "../loaddefs.el" | |
1fe1547a CY |
328 | ;; generated-autoload-load-name: "semantic/analyze/refs" |
329 | ;; End: | |
330 | ||
3999968a | 331 | ;; arch-tag: f8c59a91-1829-42b3-b083-437c6881841c |
a6de3d1a | 332 | ;;; semantic/analyze/refs.el ends here |