code.delx.au - gnu-emacs/blob - lisp/cedet/srecode/semantic.el

   1 ;;; srecode/semantic.el --- Semantic specific extensions to SRecode.
   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 ;; 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)
  40 (require 'semantic/senator)
  41 (require 'ring)
  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 features 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 its parts into the dictionary.
 199 (defun srecode-semantic-handle-:tag (dict)
 200   "Add macros into the dictionary DICT based on the current :tag."
 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)
 217   "Add macros into the dictionary DICT based on a tag of class type at point.
 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)
 286   "Insert TAG into a buffer using srecode templates at point.
 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 `declaration'
 309 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
 319 text based on any occurrence of a point-inserter.  Templates such
 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 overridden.
 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
 431 ;;; srecode/semantic.el ends here