summaryrefslogtreecommitdiff
path: root/lisp/cedet/semantic/analyze/refs.el
blob: 55fcd8304335ded059ddbcbdbaff1e31f8956c2f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
;;; semantic/analyze/refs.el --- Analysis of the references between tags.

;; Copyright (C) 2008-2017 Free Software Foundation, Inc.

;; Author: Eric M. Ludlam <zappo@gnu.org>

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Analyze the references between tags.
;;
;; The original purpose of these analysis is to provide a way to jump
;; between a prototype and implementation.
;;
;; Finding all prototype/impl matches is hard because you have to search
;; through the entire set of allowed databases to capture all possible
;; refs.  The core analysis class stores basic starting point, and then
;; entire raw search data, which is expensive to calculate.
;;
;; Once the raw data is available, queries for impl, prototype, or
;; perhaps other things become cheap.

(require 'semantic)
(require 'semantic/analyze)
(require 'semantic/db-find)
(eval-when-compile (require 'semantic/find))

(declare-function data-debug-new-buffer "data-debug")
(declare-function data-debug-insert-object-slots "eieio-datadebug")
(declare-function semantic-momentary-highlight-tag "semantic/decorate")

;;; Code:
(defclass semantic-analyze-references ()
  ((tag :initarg :tag
	:type semantic-tag
	:documentation
	"The starting TAG we are providing references analysis for.")
   (tagdb :initarg :tagdb
	  :documentation
	  "The database that tag can be found in.")
   (scope :initarg :scope
	  :documentation "A Scope object.")
   (rawsearchdata :initarg :rawsearchdata
		  :documentation
		  "The raw search data for TAG's name across all databases.")
   ;; Note: Should I cache queried data here?  I expect that searching
   ;; through rawsearchdata will be super-fast, so why bother?
   )
  "Class containing data from a semantic analysis.")

(define-overloadable-function semantic-analyze-tag-references (tag &optional db)
  "Analyze the references for TAG.
Returns a class with information about TAG.

Optional argument DB is a database.  It will be used to help
locate TAG.

Use `semantic-analyze-current-tag' to debug this fcn.")

(defun semantic-analyze-tag-references-default (tag &optional db)
  "Analyze the references for TAG.
Returns a class with information about TAG.

Optional argument DB is a database.  It will be used to help
locate TAG.

Use `semantic-analyze-current-tag' to debug this fcn."
  (when (not (semantic-tag-p tag))  (signal 'wrong-type-argument (list 'semantic-tag-p tag)))
  (let ((allhits nil)
	(scope nil)
	)
    (save-excursion
      (semantic-go-to-tag tag db)
      (setq scope (semantic-calculate-scope))

      (setq allhits (semantic--analyze-refs-full-lookup tag scope t))

      (semantic-analyze-references (semantic-tag-name tag)
				    :tag tag
				    :tagdb db
				    :scope scope
				    :rawsearchdata allhits)
      )))

;;; METHODS
;;
;; These accessor methods will calculate the useful bits from the context, and cache values
;; into the context.
(cl-defmethod semantic-analyze-refs-impl ((refs semantic-analyze-references) &optional in-buffer)
  "Return the implementations derived in the reference analyzer REFS.
Optional argument IN-BUFFER indicates that the returned tag should be in an active buffer."
  (let ((allhits (oref refs rawsearchdata))
	(tag (oref refs :tag))
	(impl nil)
	)
    (semanticdb-find-result-mapc
     (lambda (T DB)
       "Examine T in the database DB, and sort it."
       (let* ((ans (semanticdb-normalize-one-tag DB T))
	      (aT (cdr ans))
	      (aDB (car ans))
	      )
	 (when (and (not (semantic-tag-prototype-p aT))
		    (semantic-tag-similar-p tag aT
					    :prototype-flag
					    :parent
					    :typemodifiers
					    :default-value))
	   (when in-buffer (save-excursion (semantic-go-to-tag aT aDB)))
	   (push aT impl))))
     allhits)
    impl))

(cl-defmethod semantic-analyze-refs-proto ((refs semantic-analyze-references) &optional in-buffer)
  "Return the prototypes derived in the reference analyzer REFS.
Optional argument IN-BUFFER indicates that the returned tag should be in an active buffer."
  (let ((allhits (oref refs rawsearchdata))
	(tag (oref refs :tag))
	(proto nil))
    (semanticdb-find-result-mapc
     (lambda (T DB)
       "Examine T in the database DB, and sort it."
       (let* ((ans (semanticdb-normalize-one-tag DB T))
	      (aT (cdr ans))
	      (aDB (car ans))
	      )
	 (when (and (semantic-tag-prototype-p aT)
		    (semantic-tag-similar-p tag aT
					    :prototype-flag
					    :parent
					    :typemodifiers
					    :default-value))
	   (when in-buffer (save-excursion (semantic-go-to-tag aT aDB)))
	   (push aT proto))))
     allhits)
    proto))

;;; LOOKUP
;;
(defun semantic--analyze-refs-full-lookup (tag scope &optional noerror)
  "Perform a full lookup for all occurrences of TAG in the current project.
TAG should be the tag currently under point.
SCOPE is the scope the cursor is in.  From this a list of parents is
derived.  If SCOPE does not have parents, then only a simple lookup is done.
Optional argument NOERROR means don't error if the lookup fails."
  (if (not (oref scope parents))
      ;; If this tag has some named parent, but is not
      (semantic--analyze-refs-full-lookup-simple tag noerror)

    ;; We have some sort of lineage we need to consider when we do
    ;; our side lookup of tags.
    (semantic--analyze-refs-full-lookup-with-parents tag scope)
    ))

(defun semantic--analyze-refs-find-child-in-find-results (find-results name class)
  "Find in FIND-RESULT a tag NAME which is a child of a tag in FIND-RESULTS.
CLASS is the class of the tag that ought to be returned."
  (let ((ans nil)
	(subans nil))
    ;; Loop over each segment of the find results.
    (dolist (FDB find-results)
      (setq subans nil)
      ;; Loop over each tag in the find results.
      (dolist (T (cdr FDB))
	;; For each tag, get the children.
	(let* ((chil (semantic-tag-type-members T))
	       (match (semantic-find-tags-by-name name chil)))
	  ;; Go over the matches, looking for matching tag class.
	  (dolist (M match)
	    (when (semantic-tag-of-class-p M class)
	      (push M subans)))))
      ;; Store current matches into a new find results.
      (when subans
	(push (cons (car FDB) subans) ans))
      )
    ans))

(defun semantic--analyze-refs-find-tags-with-parent (find-results parents)
  "Find in FIND-RESULTS all tags with PARENTS.
NAME is the name of the tag needing finding.
PARENTS is a list of names."
  (let ((ans nil) (usingnames nil))
    ;; Loop over the find-results passed in.
    (semanticdb-find-result-mapc
     (lambda (tag db)
       (let* ((p (semantic-tag-named-parent tag))
	      (ps (when (stringp p) (semantic-analyze-split-name p))))
	 (when (stringp ps) (setq ps (list ps)))
	 (when ps
	   ;; If there is a perfect match, then use it.
	   (if (equal ps parents)
	       (push (list db tag) ans))
	   ;; No match, find something from our list of using names.
	   ;; Do we need to split UN?
	   (save-excursion
	     (semantic-go-to-tag tag db)
	     (setq usingnames nil)
	     (let ((imports (semantic-ctxt-imported-packages)))
	       ;; Derive the names from all the using statements.
	       (mapc (lambda (T)
		       (setq usingnames
			     (cons (semantic-format-tag-name-from-anything T) usingnames)))
		     imports))
	     (dolist (UN usingnames)
	       (when (equal (cons UN ps) parents)
		 (push (list db tag) ans)
		 (setq usingnames (cdr usingnames))))
	     ))))
     find-results)
    ans))

(defun semantic--analyze-refs-full-lookup-with-parents (tag scope)
  "Perform a lookup for all occurrences of TAG based on TAG's SCOPE.
TAG should be the tag currently under point."
  (let* ((classmatch (semantic-tag-class tag))
	 (plist (mapcar (lambda (T) (semantic-tag-name T)) (oref scope parents)))
	 ;; The first item in the parent list
	 (name (car plist))
	 ;; Stuff from the simple list.
	 (simple (semantic--analyze-refs-full-lookup-simple tag t))
	 ;; Find all hits for the first parent name.
	 (brute (semanticdb-find-tags-collector
		 (lambda (table tags)
		   (semanticdb-deep-find-tags-by-name-method table name tags)
		   )
		 nil nil t))
	 ;; Prime the answer.
	 (answer (semantic--analyze-refs-find-tags-with-parent simple plist))
	 )
    ;; First parent is already search to initialize "brute".
    (setq plist (cdr plist))

    ;; Go through the list of parents, and try to find matches.
    ;; As we cycle through plist, for each level look for NAME,
    ;; and compare the named-parent, and also dive into the next item of
    ;; plist.
    (while (and plist brute)

      ;; Find direct matches
      (let* ((direct (semantic--analyze-refs-find-child-in-find-results
		      brute (semantic-tag-name tag) classmatch))
	     (pdirect (semantic--analyze-refs-find-tags-with-parent
		       direct plist)))
	(setq answer (append pdirect answer)))

      ;; The next set of search items.
      (setq brute (semantic--analyze-refs-find-child-in-find-results
		   brute (car plist) 'type))

      (setq plist (cdr plist)))

    ;; Brute now has the children from the very last match.
    (let* ((direct (semantic--analyze-refs-find-child-in-find-results
		    brute (semantic-tag-name tag) classmatch))
	   )
      (setq answer (append direct answer)))

    answer))

(defun semantic--analyze-refs-full-lookup-simple (tag &optional noerror)
  "Perform a simple  lookup for occurrences of TAG in the current project.
TAG should be the tag currently under point.
Optional NOERROR means don't throw errors on failure to find something.
This only compares the tag name, and does not infer any matches in namespaces,
or parts of some other data structure.
Only works for tags in the global namespace."
  (let* ((name (semantic-tag-name tag))
	 (brute (semanticdb-find-tags-collector
		 (lambda (table tags)
		   (semanticdb-find-tags-by-name-method table name tags)
		   )
		 nil ;; This may need to be the entire project??
		 nil t))
	 )

	(when (and (not brute) (not noerror))
	  ;; An error, because tag under point ought to be found.
	  (error "Cannot find any references to %s in wide search" name))

	(let* ((classmatch (semantic-tag-class tag))
	       (RES
		(semanticdb-find-tags-collector
		 (lambda (table tags)
		   (semantic-find-tags-by-class classmatch tags)
		   ;; @todo - Add parent check also.
		   )
		 brute nil)))

	  (when (and (not RES) (not noerror))
	    (error "Cannot find any definitions for %s in wide search"
		   (semantic-tag-name tag)))

	  ;; Return the matching tags and databases.
	  RES)))


;;; USER COMMANDS
;;
;;;###autoload
(defun semantic-analyze-current-tag ()
  "Analyze the tag under point."
  (interactive)
  (let* ((tag (semantic-current-tag))
	 (start (current-time))
	 (sac (semantic-analyze-tag-references tag))
	 (end (current-time))
	 )
    (message "Analysis took %.2f seconds." (semantic-elapsed-time start end))
    (if sac
	(progn
	  (require 'eieio-datadebug)
	  (data-debug-new-buffer "*Analyzer Reference ADEBUG*")
	  (data-debug-insert-object-slots sac "]"))
      (message "No Context to analyze here."))))

;;;###autoload
(defun semantic-analyze-proto-impl-toggle ()
  "Toggle between the implementation, and a prototype of tag under point."
  (interactive)
  (require 'semantic/decorate)
  (semantic-fetch-tags)
  (let* ((tag (semantic-current-tag))
	 (sar (if tag
		  (semantic-analyze-tag-references tag)
		(error "Point must be in a declaration")))
	 (target (if (semantic-tag-prototype-p tag)
		     (car (semantic-analyze-refs-impl sar t))
		   (car (semantic-analyze-refs-proto sar t))))
	 )

    (when (not target)
      (error "Could not find suitable %s"
	     (if (semantic-tag-prototype-p tag) "implementation" "prototype")))

    (push-mark)
    (semantic-go-to-tag target)
    (switch-to-buffer (current-buffer))
    (semantic-momentary-highlight-tag target))
  )

(provide 'semantic/analyze/refs)

;; Local variables:
;; generated-autoload-file: "../loaddefs.el"
;; generated-autoload-load-name: "semantic/analyze/refs"
;; End:

;;; semantic/analyze/refs.el ends here