Commit | Line | Data |
---|---|---|
4d902e6f CY |
1 | ;;; srecode/semantic.el --- Semantic specific extensions to SRecode. |
2 | ||
114f9c96 | 3 | ;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. |
4d902e6f CY |
4 | |
5 | ;; Author: Eric M. Ludlam <eric@siege-engine.com> | |
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 | ;; Semantic specific extensions to the Semantic Recoder. | |
25 | ;; | |
26 | ;; I realize it is the "Semantic Recoder", but most of srecode | |
27 | ;; is a template library and set of user interfaces unrelated to | |
28 | ;; semantic in the specific. | |
29 | ;; | |
30 | ;; This file defines the following: | |
31 | ;; - :tag argument handling. | |
32 | ;; - <more goes here> | |
33 | ||
34 | ;;; Code: | |
35 | ||
36 | (require 'srecode/insert) | |
37 | (require 'srecode/dictionary) | |
38 | (require 'semantic/find) | |
39 | (require 'semantic/format) | |
b90caf50 | 40 | (require 'semantic/senator) |
4d902e6f | 41 | (require 'ring) |
4d902e6f CY |
42 | |
43 | \f | |
44 | ;;; The SEMANTIC TAG inserter | |
45 | ;; | |
46 | ;; Put a tag into the dictionary that can be used w/ arbitrary | |
47 | ;; lisp expressions. | |
48 | ||
49 | (defclass srecode-semantic-tag (srecode-dictionary-compound-value) | |
50 | ((prime :initarg :prime | |
51 | :type semantic-tag | |
52 | :documentation | |
53 | "This is the primary insertion tag.") | |
54 | ) | |
55 | "Wrap up a collection of semantic tag information. | |
56 | This class will be used to derive dictionary values.") | |
57 | ||
58 | (defmethod srecode-compound-toString((cp srecode-semantic-tag) | |
59 | function | |
60 | dictionary) | |
61 | "Convert the compound dictionary value CP to a string. | |
62 | If FUNCTION is non-nil, then FUNCTION is somehow applied to an | |
63 | aspect of the compound value." | |
64 | (if (not function) | |
65 | ;; Just format it in some handy dandy way. | |
66 | (semantic-format-tag-prototype (oref cp :prime)) | |
67 | ;; Otherwise, apply the function to the tag itself. | |
68 | (funcall function (oref cp :prime)) | |
69 | )) | |
70 | ||
71 | \f | |
72 | ;;; Managing the `current' tag | |
73 | ;; | |
74 | ||
75 | (defvar srecode-semantic-selected-tag nil | |
76 | "The tag selected by a :tag template argument. | |
77 | If this is nil, then `senator-tag-ring' is used.") | |
78 | ||
79 | (defun srecode-semantic-tag-from-kill-ring () | |
80 | "Create an `srecode-semantic-tag' from the senator kill ring." | |
81 | (if (ring-empty-p senator-tag-ring) | |
82 | (error "You must use `senator-copy-tag' to provide a tag to this template")) | |
83 | (ring-ref senator-tag-ring 0)) | |
84 | ||
85 | \f | |
86 | ;;; TAG in a DICTIONARY | |
87 | ;; | |
88 | (defvar srecode-semantic-apply-tag-augment-hook nil | |
89 | "A function called for each tag added to a dictionary. | |
90 | The hook is called with two arguments, the TAG and DICT | |
91 | to be augmented.") | |
92 | ||
93 | (define-overload srecode-semantic-apply-tag-to-dict (tagobj dict) | |
94 | "Insert fewatures of TAGOBJ into the dictionary DICT. | |
95 | TAGOBJ is an object of class `srecode-semantic-tag'. This class | |
96 | is a compound inserter value. | |
97 | DICT is a dictionary object. | |
98 | At a minimum, this function will create dictionary macro for NAME. | |
99 | It is also likely to create macros for TYPE (data type), function arguments, | |
100 | variable default values, and other things." | |
101 | ) | |
102 | ||
103 | (defun srecode-semantic-apply-tag-to-dict-default (tagobj dict) | |
104 | "Insert features of TAGOBJ into dictionary DICT." | |
105 | ;; Store the sst into the dictionary. | |
106 | (srecode-dictionary-set-value dict "TAG" tagobj) | |
107 | ||
108 | ;; Pull out the tag for the individual pieces. | |
109 | (let ((tag (oref tagobj :prime))) | |
110 | ||
111 | (srecode-dictionary-set-value dict "NAME" (semantic-tag-name tag)) | |
112 | (srecode-dictionary-set-value dict "TYPE" (semantic-format-tag-type tag nil)) | |
113 | ||
114 | (run-hook-with-args 'srecode-semantic-apply-tag-augment-hook tag dict) | |
115 | ||
116 | (cond | |
117 | ;; | |
118 | ;; FUNCTION | |
119 | ;; | |
120 | ((eq (semantic-tag-class tag) 'function) | |
121 | ;; FCN ARGS | |
122 | (let ((args (semantic-tag-function-arguments tag))) | |
123 | (while args | |
124 | (let ((larg (car args)) | |
125 | (subdict (srecode-dictionary-add-section-dictionary | |
126 | dict "ARGS"))) | |
127 | ;; Clean up elements in the arg list. | |
128 | (if (stringp larg) | |
129 | (setq larg (semantic-tag-new-variable | |
130 | larg nil nil))) | |
131 | ;; Apply the sub-argument to the subdictionary. | |
132 | (srecode-semantic-apply-tag-to-dict | |
133 | (srecode-semantic-tag (semantic-tag-name larg) | |
134 | :prime larg) | |
135 | subdict) | |
136 | ) | |
137 | ;; Next! | |
138 | (setq args (cdr args)))) | |
139 | ;; PARENTS | |
140 | (let ((p (semantic-tag-function-parent tag))) | |
141 | (when p | |
142 | (srecode-dictionary-set-value dict "PARENT" p) | |
143 | )) | |
144 | ;; EXCEPTIONS (java/c++) | |
145 | (let ((exceptions (semantic-tag-get-attribute tag :throws))) | |
146 | (while exceptions | |
147 | (let ((subdict (srecode-dictionary-add-section-dictionary | |
148 | dict "THROWS"))) | |
149 | (srecode-dictionary-set-value subdict "NAME" (car exceptions)) | |
150 | ) | |
151 | (setq exceptions (cdr exceptions))) | |
152 | ) | |
153 | ) | |
154 | ;; | |
155 | ;; VARIABLE | |
156 | ;; | |
157 | ((eq (semantic-tag-class tag) 'variable) | |
158 | (when (semantic-tag-variable-default tag) | |
159 | (let ((subdict (srecode-dictionary-add-section-dictionary | |
160 | dict "HAVEDEFAULT"))) | |
161 | (srecode-dictionary-set-value | |
162 | subdict "VALUE" (semantic-tag-variable-default tag)))) | |
163 | ) | |
164 | ;; | |
165 | ;; TYPE | |
166 | ;; | |
167 | ((eq (semantic-tag-class tag) 'type) | |
168 | (dolist (p (semantic-tag-type-superclasses tag)) | |
169 | (let ((sd (srecode-dictionary-add-section-dictionary | |
170 | dict "PARENTS"))) | |
171 | (srecode-dictionary-set-value sd "NAME" p) | |
172 | )) | |
173 | (dolist (i (semantic-tag-type-interfaces tag)) | |
174 | (let ((sd (srecode-dictionary-add-section-dictionary | |
175 | dict "INTERFACES"))) | |
176 | (srecode-dictionary-set-value sd "NAME" i) | |
177 | )) | |
178 | ; NOTE : The members are too complicated to do via a template. | |
179 | ; do it via the insert-tag solution instead. | |
180 | ; | |
181 | ; (dolist (mem (semantic-tag-type-members tag)) | |
182 | ; (let ((subdict (srecode-dictionary-add-section-dictionary | |
183 | ; dict "MEMBERS"))) | |
184 | ; (when (stringp mem) | |
185 | ; (setq mem (semantic-tag-new-variable mem nil nil))) | |
186 | ; (srecode-semantic-apply-tag-to-dict | |
187 | ; (srecode-semantic-tag (semantic-tag-name mem) | |
188 | ; :prime mem) | |
189 | ; subdict))) | |
190 | )))) | |
191 | ||
192 | \f | |
193 | ;;; ARGUMENT HANDLERS | |
194 | ||
195 | ;;; :tag ARGUMENT HANDLING | |
196 | ;; | |
197 | ;; When a :tag argument is required, identify the current :tag, | |
198 | ;; and apply it's parts into the dictionary. | |
199 | (defun srecode-semantic-handle-:tag (dict) | |
2f10955c | 200 | "Add macros into the dictionary DICT based on the current :tag." |
4d902e6f CY |
201 | ;; We have a tag, start adding "stuff" into the dictionary. |
202 | (let ((tag (or srecode-semantic-selected-tag | |
203 | (srecode-semantic-tag-from-kill-ring)))) | |
204 | (when (not tag) | |
205 | "No tag for current template. Use the semantic kill-ring.") | |
206 | (srecode-semantic-apply-tag-to-dict | |
207 | (srecode-semantic-tag (semantic-tag-name tag) | |
208 | :prime tag) | |
209 | dict))) | |
210 | ||
211 | ;;; :tagtype ARGUMENT HANDLING | |
212 | ;; | |
213 | ;; When a :tagtype argument is required, identify the current tag, of | |
214 | ;; cf class 'type. Apply those parameters to the dictionary. | |
215 | ||
216 | (defun srecode-semantic-handle-:tagtype (dict) | |
2f10955c | 217 | "Add macros into the dictionary DICT based on a tag of class type at point. |
4d902e6f CY |
218 | Assumes the cursor is in a tag of class type. If not, throw an error." |
219 | (let ((typetag (or srecode-semantic-selected-tag | |
220 | (semantic-current-tag-of-class 'type)))) | |
221 | (when (not typetag) | |
222 | (error "Cursor is not in a TAG of class 'type")) | |
223 | (srecode-semantic-apply-tag-to-dict | |
224 | typetag | |
225 | dict))) | |
226 | ||
227 | \f | |
228 | ;;; INSERT A TAG API | |
229 | ;; | |
230 | ;; Routines that take a tag, and insert into a buffer. | |
231 | (define-overload srecode-semantic-find-template (class prototype ctxt) | |
232 | "Find a template for a tag of class CLASS based on context. | |
233 | PROTOTYPE is non-nil if we want a prototype template instead." | |
234 | ) | |
235 | ||
236 | (defun srecode-semantic-find-template-default (class prototype ctxt) | |
237 | "Find a template for tag CLASS based on context. | |
238 | PROTOTYPE is non-nil if we need a prototype. | |
239 | CTXT is the pre-calculated context." | |
240 | (let* ((top (car ctxt)) | |
241 | (tname (if (stringp class) | |
242 | class | |
243 | (symbol-name class))) | |
244 | (temp nil) | |
245 | ) | |
246 | ;; Try to find a template. | |
247 | (setq temp (or | |
248 | (when prototype | |
249 | (srecode-template-get-table (srecode-table) | |
250 | (concat tname "-tag-prototype") | |
251 | top)) | |
252 | (when prototype | |
253 | (srecode-template-get-table (srecode-table) | |
254 | (concat tname "-prototype") | |
255 | top)) | |
256 | (srecode-template-get-table (srecode-table) | |
257 | (concat tname "-tag") | |
258 | top) | |
259 | (srecode-template-get-table (srecode-table) | |
260 | tname | |
261 | top) | |
262 | (when (and (not (string= top "declaration")) | |
263 | prototype) | |
264 | (srecode-template-get-table (srecode-table) | |
265 | (concat tname "-prototype") | |
266 | "declaration")) | |
267 | (when (and (not (string= top "declaration")) | |
268 | prototype) | |
269 | (srecode-template-get-table (srecode-table) | |
270 | (concat tname "-tag-prototype") | |
271 | "declaration")) | |
272 | (when (not (string= top "declaration")) | |
273 | (srecode-template-get-table (srecode-table) | |
274 | (concat tname "-tag") | |
275 | "declaration")) | |
276 | (when (not (string= top "declaration")) | |
277 | (srecode-template-get-table (srecode-table) | |
278 | tname | |
279 | "declaration")) | |
280 | )) | |
281 | temp)) | |
282 | ||
283 | (defun srecode-semantic-insert-tag (tag &optional style-option | |
284 | point-insert-fcn | |
285 | &rest dict-entries) | |
2f10955c | 286 | "Insert TAG into a buffer using srecode templates at point. |
4d902e6f CY |
287 | |
288 | Optional STYLE-OPTION is a list of minor configuration of styles, | |
289 | such as the symbol 'prototype for prototype functions, or | |
290 | 'system for system includes, and 'doxygen, for a doxygen style | |
291 | comment. | |
292 | ||
293 | Optional third argument POINT-INSERT-FCN is a hook that is run after | |
294 | TAG is inserted that allows an opportunity to fill in the body of | |
295 | some thing. This hook function is called with one argument, the TAG | |
296 | being inserted. | |
297 | ||
298 | The rest of the arguments are DICT-ENTRIES. DICT-ENTRIES | |
299 | is of the form ( NAME1 VALUE1 NAME2 VALUE2 ... NAMEn VALUEn). | |
300 | ||
301 | The exact template used is based on the current context. | |
302 | The template used is found within the toplevel context as calculated | |
303 | by `srecode-calculate-context', such as `declaration', `classdecl', | |
304 | or `code'. | |
305 | ||
306 | For various conditions, this function looks for a template with | |
307 | the name CLASS-tag, where CLASS is the tag class. If it cannot | |
308 | find that, it will look for that template in the | |
309 | `declaration'context (if the current context was not `declaration'). | |
310 | ||
311 | If PROTOTYPE is specified, it will first look for templates with | |
312 | the name CLASS-tag-prototype, or CLASS-prototype as above. | |
313 | ||
314 | See `srecode-semantic-apply-tag-to-dict' for details on what is in | |
315 | the dictionary when the templates are called. | |
316 | ||
317 | This function returns to location in the buffer where the | |
318 | inserted tag ENDS, and will leave point inside the inserted | |
2f10955c | 319 | text based on any occurrence of a point-inserter. Templates such |
4d902e6f CY |
320 | as `function' will leave point where code might be inserted." |
321 | (srecode-load-tables-for-mode major-mode) | |
322 | (let* ((ctxt (srecode-calculate-context)) | |
323 | (top (car ctxt)) | |
324 | (tname (symbol-name (semantic-tag-class tag))) | |
325 | (dict (srecode-create-dictionary)) | |
326 | (temp nil) | |
327 | (errtype tname) | |
328 | (prototype (memq 'prototype style-option)) | |
329 | ) | |
330 | ;; Try some special cases. | |
331 | (cond ((and (semantic-tag-of-class-p tag 'function) | |
332 | (semantic-tag-get-attribute tag :constructor-flag)) | |
333 | (setq temp (srecode-semantic-find-template | |
334 | "constructor" prototype ctxt)) | |
335 | ) | |
336 | ||
337 | ((and (semantic-tag-of-class-p tag 'function) | |
338 | (semantic-tag-get-attribute tag :destructor-flag)) | |
339 | (setq temp (srecode-semantic-find-template | |
340 | "destructor" prototype ctxt)) | |
341 | ) | |
342 | ||
343 | ((and (semantic-tag-of-class-p tag 'function) | |
344 | (semantic-tag-function-parent tag)) | |
345 | (setq temp (srecode-semantic-find-template | |
346 | "method" prototype ctxt)) | |
347 | ) | |
348 | ||
349 | ((and (semantic-tag-of-class-p tag 'variable) | |
350 | (semantic-tag-get-attribute tag :constant-flag)) | |
351 | (setq temp (srecode-semantic-find-template | |
352 | "variable-const" prototype ctxt)) | |
353 | ) | |
354 | ) | |
355 | ||
356 | (when (not temp) | |
357 | ;; Try the basics | |
358 | (setq temp (srecode-semantic-find-template | |
359 | tname prototype ctxt))) | |
360 | ||
361 | ;; Try some backup template names. | |
362 | (when (not temp) | |
363 | (cond | |
364 | ;; Types might split things up based on the type's type. | |
365 | ((and (eq (semantic-tag-class tag) 'type) | |
366 | (semantic-tag-type tag)) | |
367 | (setq temp (srecode-semantic-find-template | |
368 | (semantic-tag-type tag) prototype ctxt)) | |
369 | (setq errtype (concat errtype " or " (semantic-tag-type tag))) | |
370 | ) | |
371 | ;; A function might be an externally declared method. | |
372 | ((and (eq (semantic-tag-class tag) 'function) | |
373 | (semantic-tag-function-parent tag)) | |
374 | (setq temp (srecode-semantic-find-template | |
375 | "method" prototype ctxt))) | |
376 | (t | |
377 | nil) | |
378 | )) | |
379 | ||
380 | ;; Can't find one? Drat! | |
381 | (when (not temp) | |
382 | (error "Cannot find template %s in %s for inserting tag %S" | |
383 | errtype top (semantic-format-tag-summarize tag))) | |
384 | ||
385 | ;; Resolve Arguments | |
386 | (let ((srecode-semantic-selected-tag tag)) | |
387 | (srecode-resolve-arguments temp dict)) | |
388 | ||
389 | ;; Resolve TAG into the dictionary. We may have a :tag arg | |
390 | ;; from the macro such that we don't need to do this. | |
391 | (when (not (srecode-dictionary-lookup-name dict "TAG")) | |
392 | (let ((tagobj (srecode-semantic-tag (semantic-tag-name tag) :prime tag)) | |
393 | ) | |
394 | (srecode-semantic-apply-tag-to-dict tagobj dict))) | |
395 | ||
396 | ;; Insert dict-entries into the dictionary LAST so that previous | |
397 | ;; items can be overriden. | |
398 | (let ((entries dict-entries)) | |
399 | (while entries | |
400 | (srecode-dictionary-set-value dict | |
401 | (car entries) | |
402 | (car (cdr entries))) | |
403 | (setq entries (cdr (cdr entries))))) | |
404 | ||
405 | ;; Insert the template. | |
406 | (let ((endpt (srecode-insert-fcn temp dict nil t))) | |
407 | ||
408 | (run-hook-with-args 'point-insert-fcn tag) | |
409 | ;;(sit-for 1) | |
410 | ||
411 | (cond | |
412 | ((semantic-tag-of-class-p tag 'type) | |
413 | ;; Insert all the members at the current insertion point. | |
414 | (dolist (m (semantic-tag-type-members tag)) | |
415 | ||
416 | (when (stringp m) | |
417 | (setq m (semantic-tag-new-variable m nil nil))) | |
418 | ||
419 | ;; We do prototypes w/in the class decl? | |
420 | (let ((me (srecode-semantic-insert-tag m '(prototype)))) | |
421 | (goto-char me)) | |
422 | ||
423 | )) | |
424 | ) | |
425 | ||
426 | endpt) | |
427 | )) | |
428 | ||
429 | (provide 'srecode/semantic) | |
430 | ||
3999968a | 431 | ;; arch-tag: b87ccbd6-bd87-48bc-8182-1043a9052d79 |
4d902e6f | 432 | ;;; srecode/semantic.el ends here |