lisp/cedet/srecode/getset.el

   1 ;;; srecode/getset.el --- Package for inserting new get/set methods.
   2
   3 ;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
   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   (semantic-fetch-tags)
  59   (let* ((class (or class-in (srecode-auto-choose-class (point))))
  60          (tagstart (when class (semantic-tag-start class)))
  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)
 218           ;; If there is a comment immediately after aftertag, skip over it.
 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))
 301          )
 302
 303     (or (semantic-find-tags-by-name sel kids)
 304         sel)
 305     ))
 306
 307 (defun srecode-auto-choose-class (point)
 308   "Choose a class based on location of POINT."
 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"
 363 ;; generated-autoload-load-name: "srecode/getset"
 364 ;; End:
 365
 366 ;;; srecode/getset.el ends here