1 ;;; srecode/getset.el --- Package for inserting new get/set methods.
3 ;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
5 ;; Author: Eric M. Ludlam <eric@siege-engine.com>
7 ;; This file is part of GNU Emacs.
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.
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.
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/>.
24 ;; SRecoder application for inserting new get/set methods into a class.
27 (require 'semantic
/analyze
)
28 (require 'semantic
/find
)
29 (require 'srecode
/insert
)
30 (require 'srecode
/dictionary
)
33 (defvar srecode-insert-getset-fully-automatic-flag nil
34 "Non-nil means accept choices srecode comes up with without asking.")
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
45 (srecode-load-tables-for-mode major-mode
)
46 (srecode-load-tables-for-mode major-mode
'getset
)
48 (if (not (srecode-table))
49 (error "No template table found for mode %s" major-mode
))
51 (if (not (srecode-template-get-table (srecode-table)
55 (error "No templates for inserting get/set"))
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
))
65 (error "Move point to a class and try again"))
67 ;; Step 2: Select a name for the field we will use.
69 (setq field field-in
))
71 (when (and inclass
(not field
))
72 (setq field
(srecode-auto-choose-field (point))))
75 (setq field
(srecode-query-for-field class
)))
77 ;; Step 3: Insert a new field if needed
81 (srecode-position-new-field class inclass
)
83 (let* ((dict (srecode-create-dictionary))
84 (temp (srecode-template-get-table (srecode-table)
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
)
100 ;; Refresh our class tag.
101 (setq class
(srecode-auto-choose-class (point)))
104 (let ((tmptag (semantic-deep-find-tags-by-name-regexp
105 field
(current-buffer))))
106 (setq tmptag
(semantic-find-tags-by-class 'variable tmptag
))
109 (setq field
(car tmptag
))
110 (error "Could not find new field %s" field
)))
113 ;; Step 3.5: Insert an initializer if needed.
117 ;; Set up for the rest.
120 (if (not (semantic-tag-p field
))
121 (error "Must specify field for get/set. (parts may not be impl'd yet.)"))
123 ;; Set 4: Position for insertion of methods
124 (srecode-position-new-methods class field
)
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.
132 (let* ((dict (srecode-create-dictionary))
133 (srecode-semantic-selected-tag field
)
134 (temp (srecode-template-get-table (srecode-table)
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
)
145 (srecode-dictionary-set-value dict
"NICENAME"
146 (srecode-strip-fieldname
147 (semantic-tag-name field
)))
148 (srecode-insert-fcn temp dict
)
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.
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
)
165 (let ((prev (semantic-find-tag-by-overlay-prev))
166 (next (semantic-find-tag-by-overlay-next))
171 ((and prev
(semantic-tag-of-class-p prev
'variable
))
174 (srecode-strip-fieldname (semantic-tag-name prev
))))
176 ((and next
(semantic-tag-of-class-p next
'variable
))
179 (srecode-strip-fieldname (semantic-tag-name prev
)))))
182 (setq aftertag
(semantic-find-first-tag-by-name
183 setname
(semantic-tag-type-members class
)))
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
))
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
))
206 (setq aftertag
(semantic-find-first-tag-by-name
207 "public" (semantic-tag-type-members class
))))
210 (setq aftertag
(car (semantic-tag-type-members class
))))
213 (let ((te (semantic-tag-end aftertag
)))
215 (message "Unknown location for tag-end in %s:" (semantic-tag-name aftertag
)))
217 ;; If there is a comment immediatly after aftertag, skip over it.
218 (when (looking-at (concat "\\s-*\n?\\s-*" semantic-lex-comment-regex
))
220 (rnext (semantic-find-tag-by-overlay-next (point))))
222 ;; Make sure the comment we skipped didn't say anything about
226 (regexp-quote (semantic-tag-name rnext
)) pos t
))
227 ;; It did mention rnext, so go back to our starting position.
233 ;; At the very beginning of the class.
234 (goto-char (semantic-tag-end class
))
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."
249 ;; If we aren't in the class, get the cursor there, pronto!
252 (error "You must position the cursor where to insert the new field")
254 (let ((kids (semantic-find-tags-by-class
255 'variable
(semantic-tag-type-members class
))))
257 (semantic-go-to-tag (car kids
) class
))
259 (semantic-go-to-tag class
)))
262 (switch-to-buffer (current-buffer))
264 ;; Once the cursor is in our class, ask the user to position
265 ;; the cursor to keep going.
268 (if (or srecode-insert-getset-fully-automatic-flag
269 (y-or-n-p "Insert new field here? "))
271 (error "You must position the cursor where to insert the new field first"))
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."
283 (let ((field (semantic-current-tag-of-class 'variable
)))
285 ;; If we get a field, make sure the user gets a chance to choose.
287 (if srecode-insert-getset-fully-automatic-flag
290 (format "Use field %s? " (semantic-tag-name field
))))
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
))
302 (or (semantic-find-tags-by-name sel kids
)
306 (defun srecode-auto-choose-class (point)
307 "Choose a class based on location of POINT."
312 (let ((tag (semantic-current-tag-of-class 'type
)))
315 (not (string= (semantic-tag-type tag
) "class")))
316 ;; The current tag is not a class. Are we in a fcn
318 (setq tag
(semantic-current-tag-of-class 'function
))
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.
326 (let* ((searchname (cond ((stringp p
) p
)
328 (semantic-tag-name p
))
329 ((and (listp p
) (stringp (car p
)))
331 (ptag (semantic-analyze-find-tag searchname
333 (when ptag
(setq tag ptag
))
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))
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
))
352 (setq ans
(car pfix
)))
353 (setq pfix
(cdr pfix
))))
358 (provide 'srecode
/getset
)
361 ;; generated-autoload-file: "loaddefs.el"
362 ;; generated-autoload-load-name: "srecode/getset"
365 ;; arch-tag: c2098b7a-df7f-4e8a-a9e3-2be8798a7554
366 ;;; srecode/getset.el ends here