Commit | Line | Data |
---|---|---|
4d902e6f CY |
1 | ;;; srecode/getset.el --- Package for inserting new get/set methods. |
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 | ;; SRecoder application for inserting new get/set methods into a class. | |
25 | ||
26 | (require 'semantic) | |
27 | (require 'semantic/analyze) | |
28 | (require 'semantic/find) | |
29 | (require 'srecode/insert) | |
30 | (require 'srecode/dictionary) | |
31 | ||
32 | ;;; Code: | |
33 | (defvar srecode-insert-getset-fully-automatic-flag nil | |
34 | "Non-nil means accept choices srecode comes up with without asking.") | |
35 | ||
36 | ;;;###autoload | |
37 | (defun srecode-insert-getset (&optional class-in field-in) | |
38 | "Insert get/set methods for the current class. | |
39 | CLASS-IN is the semantic tag of the class to update. | |
40 | FIELD-IN is the semantic tag, or string name, of the field to add. | |
41 | If you do not specify CLASS-IN or FIELD-IN then a class and field | |
42 | will be derived." | |
43 | (interactive) | |
44 | ||
45 | (srecode-load-tables-for-mode major-mode) | |
46 | (srecode-load-tables-for-mode major-mode 'getset) | |
47 | ||
48 | (if (not (srecode-table)) | |
49 | (error "No template table found for mode %s" major-mode)) | |
50 | ||
51 | (if (not (srecode-template-get-table (srecode-table) | |
52 | "getset-in-class" | |
53 | "declaration" | |
54 | 'getset)) | |
55 | (error "No templates for inserting get/set")) | |
56 | ||
57 | ;; Step 1: Try to derive the tag for the class we will use | |
58 | (let* ((class (or class-in (srecode-auto-choose-class (point)))) | |
59 | (tagstart (semantic-tag-start class)) | |
60 | (inclass (eq (semantic-current-tag-of-class 'type) class)) | |
61 | (field nil) | |
62 | ) | |
63 | ||
64 | (when (not class) | |
65 | (error "Move point to a class and try again")) | |
66 | ||
67 | ;; Step 2: Select a name for the field we will use. | |
68 | (when field-in | |
69 | (setq field field-in)) | |
70 | ||
71 | (when (and inclass (not field)) | |
72 | (setq field (srecode-auto-choose-field (point)))) | |
73 | ||
74 | (when (not field) | |
75 | (setq field (srecode-query-for-field class))) | |
76 | ||
77 | ;; Step 3: Insert a new field if needed | |
78 | (when (stringp field) | |
79 | ||
80 | (goto-char (point)) | |
81 | (srecode-position-new-field class inclass) | |
82 | ||
83 | (let* ((dict (srecode-create-dictionary)) | |
84 | (temp (srecode-template-get-table (srecode-table) | |
85 | "getset-field" | |
86 | "declaration" | |
87 | 'getset)) | |
88 | ) | |
89 | (when (not temp) | |
90 | (error "Getset templates for %s not loaded!" major-mode)) | |
91 | (srecode-resolve-arguments temp dict) | |
92 | (srecode-dictionary-set-value dict "NAME" field) | |
93 | (when srecode-insert-getset-fully-automatic-flag | |
94 | (srecode-dictionary-set-value dict "TYPE" "int")) | |
95 | (srecode-insert-fcn temp dict) | |
96 | ||
97 | (semantic-fetch-tags) | |
98 | (save-excursion | |
99 | (goto-char tagstart) | |
100 | ;; Refresh our class tag. | |
101 | (setq class (srecode-auto-choose-class (point))) | |
102 | ) | |
103 | ||
104 | (let ((tmptag (semantic-deep-find-tags-by-name-regexp | |
105 | field (current-buffer)))) | |
106 | (setq tmptag (semantic-find-tags-by-class 'variable tmptag)) | |
107 | ||
108 | (if tmptag | |
109 | (setq field (car tmptag)) | |
110 | (error "Could not find new field %s" field))) | |
111 | ) | |
112 | ||
113 | ;; Step 3.5: Insert an initializer if needed. | |
114 | ;; ... | |
115 | ||
116 | ||
117 | ;; Set up for the rest. | |
118 | ) | |
119 | ||
120 | (if (not (semantic-tag-p field)) | |
121 | (error "Must specify field for get/set. (parts may not be impl'd yet.)")) | |
122 | ||
123 | ;; Set 4: Position for insertion of methods | |
124 | (srecode-position-new-methods class field) | |
125 | ||
126 | ;; Step 5: Insert the get/set methods | |
127 | (if (not (eq (semantic-current-tag) class)) | |
128 | ;; We are positioned on top of something else. | |
129 | ;; insert a /n | |
130 | (insert "\n")) | |
131 | ||
132 | (let* ((dict (srecode-create-dictionary)) | |
133 | (srecode-semantic-selected-tag field) | |
134 | (temp (srecode-template-get-table (srecode-table) | |
135 | "getset-in-class" | |
136 | "declaration" | |
137 | 'getset)) | |
138 | ) | |
139 | (if (not temp) | |
140 | (error "Getset templates for %s not loaded!" major-mode)) | |
141 | (srecode-resolve-arguments temp dict) | |
142 | (srecode-dictionary-set-value dict "GROUPNAME" | |
143 | (concat (semantic-tag-name field) | |
144 | " Accessors")) | |
145 | (srecode-dictionary-set-value dict "NICENAME" | |
146 | (srecode-strip-fieldname | |
147 | (semantic-tag-name field))) | |
148 | (srecode-insert-fcn temp dict) | |
149 | ))) | |
150 | ||
151 | (defun srecode-strip-fieldname (name) | |
152 | "Strip the fieldname NAME of polish notation things." | |
153 | (cond ((string-match "[a-z]\\([A-Z]\\w+\\)" name) | |
154 | (substring name (match-beginning 1))) | |
155 | ;; Add more rules here. | |
156 | (t | |
157 | name))) | |
158 | ||
159 | (defun srecode-position-new-methods (class field) | |
160 | "Position the cursor in CLASS where new getset methods should go. | |
161 | FIELD is the field for the get sets. | |
162 | INCLASS specifies if the cursor is already in CLASS or not." | |
163 | (semantic-go-to-tag field) | |
164 | ||
165 | (let ((prev (semantic-find-tag-by-overlay-prev)) | |
166 | (next (semantic-find-tag-by-overlay-next)) | |
167 | (setname nil) | |
168 | (aftertag nil) | |
169 | ) | |
170 | (cond | |
171 | ((and prev (semantic-tag-of-class-p prev 'variable)) | |
172 | (setq setname | |
173 | (concat "set" | |
174 | (srecode-strip-fieldname (semantic-tag-name prev)))) | |
175 | ) | |
176 | ((and next (semantic-tag-of-class-p next 'variable)) | |
177 | (setq setname | |
178 | (concat "set" | |
179 | (srecode-strip-fieldname (semantic-tag-name prev))))) | |
180 | (t nil)) | |
181 | ||
182 | (setq aftertag (semantic-find-first-tag-by-name | |
183 | setname (semantic-tag-type-members class))) | |
184 | ||
185 | (when (not aftertag) | |
186 | (setq aftertag (car-safe | |
187 | (semantic--find-tags-by-macro | |
188 | (semantic-tag-get-attribute (car tags) :destructor-flag) | |
189 | (semantic-tag-type-members class)))) | |
190 | ;; Make sure the tag is public | |
191 | (when (not (eq (semantic-tag-protection aftertag class) 'public)) | |
192 | (setq aftertag nil)) | |
193 | ) | |
194 | ||
195 | (if (not aftertag) | |
196 | (setq aftertag (car-safe | |
197 | (semantic--find-tags-by-macro | |
198 | (semantic-tag-get-attribute (car tags) :constructor-flag) | |
199 | (semantic-tag-type-members class)))) | |
200 | ;; Make sure the tag is public | |
201 | (when (not (eq (semantic-tag-protection aftertag class) 'public)) | |
202 | (setq aftertag nil)) | |
203 | ) | |
204 | ||
205 | (when (not aftertag) | |
206 | (setq aftertag (semantic-find-first-tag-by-name | |
207 | "public" (semantic-tag-type-members class)))) | |
208 | ||
209 | (when (not aftertag) | |
210 | (setq aftertag (car (semantic-tag-type-members class)))) | |
211 | ||
212 | (if aftertag | |
213 | (let ((te (semantic-tag-end aftertag))) | |
214 | (when (not te) | |
215 | (message "Unknown location for tag-end in %s:" (semantic-tag-name aftertag))) | |
216 | (goto-char te) | |
217 | ;; If there is a comment immediatly after aftertag, skip over it. | |
218 | (when (looking-at (concat "\\s-*\n?\\s-*" semantic-lex-comment-regex)) | |
219 | (let ((pos (point)) | |
220 | (rnext (semantic-find-tag-by-overlay-next (point)))) | |
221 | (forward-comment 1) | |
222 | ;; Make sure the comment we skipped didn't say anything about | |
223 | ;; the rnext tag. | |
224 | (when (and rnext | |
225 | (re-search-backward | |
226 | (regexp-quote (semantic-tag-name rnext)) pos t)) | |
227 | ;; It did mention rnext, so go back to our starting position. | |
228 | (goto-char pos) | |
229 | ) | |
230 | )) | |
231 | ) | |
232 | ||
233 | ;; At the very beginning of the class. | |
234 | (goto-char (semantic-tag-end class)) | |
235 | (forward-sexp -1) | |
236 | (forward-char 1) | |
237 | ||
238 | ) | |
239 | ||
240 | (end-of-line) | |
241 | (forward-char 1) | |
242 | )) | |
243 | ||
244 | (defun srecode-position-new-field (class inclass) | |
245 | "Select a position for a new field for CLASS. | |
246 | If INCLASS is non-nil, then the cursor is already in the class | |
247 | and should not be moved during point selection." | |
248 | ||
249 | ;; If we aren't in the class, get the cursor there, pronto! | |
250 | (when (not inclass) | |
251 | ||
252 | (error "You must position the cursor where to insert the new field") | |
253 | ||
254 | (let ((kids (semantic-find-tags-by-class | |
255 | 'variable (semantic-tag-type-members class)))) | |
256 | (cond (kids | |
257 | (semantic-go-to-tag (car kids) class)) | |
258 | (t | |
259 | (semantic-go-to-tag class))) | |
260 | ) | |
261 | ||
262 | (switch-to-buffer (current-buffer)) | |
263 | ||
264 | ;; Once the cursor is in our class, ask the user to position | |
265 | ;; the cursor to keep going. | |
266 | ) | |
267 | ||
268 | (if (or srecode-insert-getset-fully-automatic-flag | |
269 | (y-or-n-p "Insert new field here? ")) | |
270 | nil | |
271 | (error "You must position the cursor where to insert the new field first")) | |
272 | ) | |
273 | ||
274 | ||
275 | ||
276 | (defun srecode-auto-choose-field (point) | |
277 | "Choose a field for the get/set methods. | |
278 | Base selection on the field related to POINT." | |
279 | (save-excursion | |
280 | (when point | |
281 | (goto-char point)) | |
282 | ||
283 | (let ((field (semantic-current-tag-of-class 'variable))) | |
284 | ||
285 | ;; If we get a field, make sure the user gets a chance to choose. | |
286 | (when field | |
287 | (if srecode-insert-getset-fully-automatic-flag | |
288 | nil | |
289 | (when (not (y-or-n-p | |
290 | (format "Use field %s? " (semantic-tag-name field)))) | |
291 | (setq field nil)) | |
292 | )) | |
293 | field))) | |
294 | ||
295 | (defun srecode-query-for-field (class) | |
296 | "Query for a field in CLASS." | |
297 | (let* ((kids (semantic-find-tags-by-class | |
298 | 'variable (semantic-tag-type-members class))) | |
299 | (sel (completing-read "Use Field: " kids)) | |
300 | ) | |
301 | ||
302 | (or (semantic-find-tags-by-name sel kids) | |
303 | sel) | |
304 | )) | |
305 | ||
306 | (defun srecode-auto-choose-class (point) | |
2f10955c | 307 | "Choose a class based on location of POINT." |
4d902e6f CY |
308 | (save-excursion |
309 | (when point | |
310 | (goto-char point)) | |
311 | ||
312 | (let ((tag (semantic-current-tag-of-class 'type))) | |
313 | ||
314 | (when (or (not tag) | |
315 | (not (string= (semantic-tag-type tag) "class"))) | |
316 | ;; The current tag is not a class. Are we in a fcn | |
317 | ;; that is a method? | |
318 | (setq tag (semantic-current-tag-of-class 'function)) | |
319 | ||
320 | (when (and tag | |
321 | (semantic-tag-function-parent tag)) | |
322 | (let ((p (semantic-tag-function-parent tag))) | |
323 | ;; @TODO : Copied below out of semantic-analyze | |
324 | ;; Turn into a routine. | |
325 | ||
326 | (let* ((searchname (cond ((stringp p) p) | |
327 | ((semantic-tag-p p) | |
328 | (semantic-tag-name p)) | |
329 | ((and (listp p) (stringp (car p))) | |
330 | (car p)))) | |
331 | (ptag (semantic-analyze-find-tag searchname | |
332 | 'type nil))) | |
333 | (when ptag (setq tag ptag )) | |
334 | )))) | |
335 | ||
336 | (when (or (not tag) | |
337 | (not (semantic-tag-of-class-p tag 'type)) | |
338 | (not (string= (semantic-tag-type tag) "class"))) | |
339 | ;; We are not in a class that needs a get/set method. | |
340 | ;; Analyze the current context, and derive a class name. | |
341 | (let* ((ctxt (semantic-analyze-current-context)) | |
342 | (pfix nil) | |
343 | (ans nil)) | |
344 | (when ctxt | |
345 | (setq pfix (reverse (oref ctxt prefix))) | |
346 | (while (and (not ans) pfix) | |
347 | ;; Start at the end and back up to the first class. | |
348 | (when (and (semantic-tag-p (car pfix)) | |
349 | (semantic-tag-of-class-p (car pfix) 'type) | |
350 | (string= (semantic-tag-type (car pfix)) | |
351 | "class")) | |
352 | (setq ans (car pfix))) | |
353 | (setq pfix (cdr pfix)))) | |
354 | (setq tag ans))) | |
355 | ||
356 | tag))) | |
357 | ||
358 | (provide 'srecode/getset) | |
359 | ||
360 | ;; Local variables: | |
361 | ;; generated-autoload-file: "loaddefs.el" | |
4d902e6f CY |
362 | ;; generated-autoload-load-name: "srecode/getset" |
363 | ;; End: | |
364 | ||
3999968a | 365 | ;; arch-tag: c2098b7a-df7f-4e8a-a9e3-2be8798a7554 |
4d902e6f | 366 | ;;; srecode/getset.el ends here |