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