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

   1 ;;; semantic/format.el --- Routines for formatting tags
   2
   3 ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
   4 ;;; 2008, 2009 Free Software Foundation, Inc.
   5
   6 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   7 ;; Keywords: syntax
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25 ;;
  26 ;; Once a language file has been parsed into a TAG, it is often useful
  27 ;; then display that tag information in browsers, completion engines, or
  28 ;; help routines.  The functions and setup in this file provide ways
  29 ;; to reformat a tag into different standard output types.
  30 ;;
  31 ;; In addition, macros for setting up customizable variables that let
  32 ;; the user choose their default format type are also provided.
  33 ;;
  34
  35 ;;; Code:
  36 (require 'semantic)
  37 (require 'semantic/tag)
  38 (require 'semantic/tag-ls)
  39 (require 'ezimage)
  40
  41 (eval-when-compile
  42   (require 'font-lock)
  43   (require 'semantic/find))
  44
  45 ;;; Tag to text overload functions
  46 ;;
  47 ;; abbreviations, prototypes, and coloring support.
  48 ;;;###autoload
  49 (defvar semantic-format-tag-functions
  50   '(semantic-format-tag-name
  51     semantic-format-tag-canonical-name
  52     semantic-format-tag-abbreviate
  53     semantic-format-tag-summarize
  54     semantic-format-tag-summarize-with-file
  55     semantic-format-tag-short-doc
  56     semantic-format-tag-prototype
  57     semantic-format-tag-concise-prototype
  58     semantic-format-tag-uml-abbreviate
  59     semantic-format-tag-uml-prototype
  60     semantic-format-tag-uml-concise-prototype
  61     semantic-format-tag-prin1
  62     )
  63   "List of functions which convert a tag to text.
  64 Each function must take the parameters TAG &optional PARENT COLOR.
  65 TAG is the tag to convert.
  66 PARENT is a parent tag or name which refers to the structure
  67 or class which contains TAG.  PARENT is NOT a class which a TAG
  68 would claim as a parent.
  69 COLOR indicates that the generated text should be colored using
  70 `font-lock'.")
  71
  72 (semantic-varalias-obsolete 'semantic-token->text-functions
  73                             'semantic-format-tag-functions)
  74 ;;;###autoload
  75 (defvar semantic-format-tag-custom-list
  76   (append '(radio)
  77           (mapcar (lambda (f) (list 'const f))
  78                   semantic-format-tag-functions)
  79           '(function))
  80   "A List used by customizeable variables to choose a tag to text function.
  81 Use this variable in the :type field of a customizable variable.")
  82
  83 (semantic-varalias-obsolete 'semantic-token->text-custom-list
  84                             'semantic-format-tag-custom-list)
  85
  86 (defcustom semantic-format-use-images-flag ezimage-use-images
  87   "Non-nil means semantic format functions use images.
  88 Images can be used as icons instead of some types of text strings."
  89   :group 'semantic
  90   :type 'boolean)
  91
  92 (defvar semantic-function-argument-separator ","
  93   "Text used to separate arguments when creating text from tags.")
  94 (make-variable-buffer-local 'semantic-function-argument-separator)
  95
  96 (defvar semantic-format-parent-separator "::"
  97   "Text used to separate names when between namespaces/classes and functions.")
  98 (make-variable-buffer-local 'semantic-format-parent-separator)
  99
 100 ;;;###autoload
 101 (define-overloadable-function semantic-format-tag-name (tag &optional parent color)
 102   "Return the name string describing TAG.
 103 The name is the shortest possible representation.
 104 Optional argument PARENT is the parent type if TAG is a detail.
 105 Optional argument COLOR means highlight the prototype with font-lock colors.")
 106
 107 (define-overloadable-function semantic-format-tag-prototype (tag &optional parent color)
 108   "Return a prototype for TAG.
 109 This function should be overloaded, though it need not be used.
 110 This is because it can be used to create code by language independent
 111 tools.
 112 Optional argument PARENT is the parent type if TAG is a detail.
 113 Optional argument COLOR means highlight the prototype with font-lock colors.")
 114
 115
 116 (defun semantic-test-all-format-tag-functions (&optional arg)
 117   "Test all outputs from `semantic-format-tag-functions'.
 118 Output is generated from the function under `point'.
 119 Optional argument ARG specifies not to use color."
 120   (interactive "P")
 121   (require 'semantic/find)
 122   (semantic-fetch-tags)
 123   (let* ((tag (semantic-current-tag))
 124          (par (semantic-current-tag-parent))
 125          (fns semantic-format-tag-functions))
 126     (with-output-to-temp-buffer "*format-tag*"
 127       (princ "Tag->format function tests:")
 128       (while fns
 129         (princ "\n")
 130         (princ (car fns))
 131         (princ ":\n ")
 132         (let ((s (funcall (car fns) tag par (not arg))))
 133           (save-excursion
 134             (set-buffer "*format-tag*")
 135             (goto-char (point-max))
 136             (insert s)))
 137         (setq fns (cdr fns))))
 138       ))
 139
 140 (defvar semantic-format-face-alist
 141   `( (function . font-lock-function-name-face)
 142      (variable . font-lock-variable-name-face)
 143      (type . font-lock-type-face)
 144      ;; These are different between Emacsen.
 145      (include . ,(if (featurep 'xemacs)
 146                      'font-lock-preprocessor-face
 147                    'font-lock-constant-face))
 148      (package . ,(if (featurep 'xemacs)
 149                      'font-lock-preprocessor-face
 150                    'font-lock-constant-face))
 151      ;; Not a tag, but instead a feature of output
 152      (label . font-lock-string-face)
 153      (comment . font-lock-comment-face)
 154      (keyword . font-lock-keyword-face)
 155      (abstract . italic)
 156      (static . underline)
 157      (documentation . font-lock-doc-face)
 158      )
 159   "Face used to colorize tags of different types.
 160 Override the value locally if a language supports other tag types.
 161 When adding new elements, try to use symbols also returned by the parser.
 162 The form of an entry in this list is of the form:
 163  ( SYMBOL .  FACE )
 164 where SYMBOL is a tag type symbol used with semantic.  FACE
 165 is a symbol representing a face.
 166 Faces used are generated in `font-lock' for consistency, and will not
 167 be used unless font lock is a feature.")
 168
 169 (semantic-varalias-obsolete 'semantic-face-alist
 170                             'semantic-format-face-alist)
 171
 172
 173 \f
 174 ;;; Coloring Functions
 175 ;;
 176 (defun semantic--format-colorize-text (text face-class)
 177   "Apply onto TEXT a color associated with FACE-CLASS.
 178 FACE-CLASS is a tag type found in `semantic-face-alist'.  See this variable
 179 for details on adding new types."
 180   (if (featurep 'font-lock)
 181       (let ((face (cdr-safe (assoc face-class semantic-format-face-alist)))
 182             (newtext (concat text)))
 183         (put-text-property 0 (length text) 'face face newtext)
 184         newtext)
 185     text))
 186
 187 (make-obsolete 'semantic-colorize-text
 188                'semantic--format-colorize-text)
 189
 190 (defun semantic--format-colorize-merge-text (precoloredtext face-class)
 191   "Apply onto PRECOLOREDTEXT a color associated with FACE-CLASS.
 192 FACE-CLASS is a tag type found in 'semantic-face-alist'.  See this
 193 variable for details on adding new types."
 194   (let ((face (cdr-safe (assoc face-class semantic-format-face-alist)))
 195         (newtext (concat precoloredtext))
 196         )
 197     (if (featurep 'xemacs)
 198         (add-text-properties 0 (length newtext) (list 'face face) newtext)
 199       (alter-text-property 0 (length newtext) 'face
 200                            (lambda (current-face)
 201                              (let ((cf
 202                                     (cond ((facep current-face)
 203                                            (list current-face))
 204                                           ((listp current-face)
 205                                            current-face)
 206                                           (t nil)))
 207                                    (nf
 208                                     (cond ((facep face)
 209                                            (list face))
 210                                           ((listp face)
 211                                            face)
 212                                           (t nil))))
 213                                (append cf nf)))
 214                            newtext))
 215     newtext))
 216
 217 ;;; Function Arguments
 218 ;;
 219 (defun semantic--format-tag-arguments (args formatter color)
 220   "Format the argument list ARGS with FORMATTER.
 221 FORMATTER is a function used to format a tag.
 222 COLOR specifies if color should be used."
 223   (let ((out nil))
 224     (while args
 225       (push (if (and formatter
 226                      (semantic-tag-p (car args))
 227                      (not (string= (semantic-tag-name (car args)) ""))
 228                      )
 229                 (funcall formatter (car args) nil color)
 230               (semantic-format-tag-name-from-anything
 231                (car args) nil color 'variable))
 232             out)
 233       (setq args (cdr args)))
 234     (mapconcat 'identity (nreverse out) semantic-function-argument-separator)
 235     ))
 236
 237 ;;; Data Type
 238 (define-overloadable-function semantic-format-tag-type (tag color)
 239   "Convert the data type of TAG to a string usable in tag formatting.
 240 It is presumed that TYPE is a string or semantic tag.")
 241
 242 (defun semantic-format-tag-type-default (tag color)
 243   "Convert the data type of TAG to a string usable in tag formatting.
 244 Argument COLOR specifies to colorize the text."
 245   (let* ((type (semantic-tag-type tag))
 246          (out (cond ((semantic-tag-p type)
 247                      (let* ((typetype (semantic-tag-type type))
 248                             (name (semantic-tag-name type))
 249                             (str (if typetype
 250                                      (concat typetype " " name)
 251                                    name)))
 252                        (if color
 253                            (semantic--format-colorize-text
 254                             str
 255                             'type)
 256                          str)))
 257                     ((and (listp type)
 258                           (stringp (car type)))
 259                      (car type))
 260                     ((stringp type)
 261                      type)
 262                     (t nil))))
 263     (if (and color out)
 264         (setq out (semantic--format-colorize-text out 'type))
 265       out)
 266     ))
 267
 268 \f
 269 ;;; Abstract formatting functions
 270
 271 (defun semantic-format-tag-prin1 (tag &optional parent color)
 272   "Convert TAG to a string that is the print name for TAG.
 273 PARENT and COLOR are ignored."
 274   (format "%S" tag))
 275
 276 (defun semantic-format-tag-name-from-anything (anything &optional
 277                                                         parent color
 278                                                         colorhint)
 279   "Convert just about anything into a name like string.
 280 Argument ANYTHING is the thing to be converted.
 281 Optional argument PARENT is the parent type if TAG is a detail.
 282 Optional argument COLOR means highlight the prototype with font-lock colors.
 283 Optional COLORHINT is the type of color to use if ANYTHING is not a tag
 284 with a tag class.  See `semantic--format-colorize-text' for a definition
 285 of FACE-CLASS for which this is used."
 286   (cond ((stringp anything)
 287          (semantic--format-colorize-text anything colorhint))
 288         ((semantic-tag-p anything)
 289          (let ((ans (semantic-format-tag-name anything parent color)))
 290            ;; If ANS is empty string or nil, then the name wasn't
 291            ;; supplied.  The implication is as in C where there is a data
 292            ;; type but no name for a prototype from an include file, or
 293            ;; an argument just wasn't used in the body of the fcn.
 294            (if (or (null ans) (string= ans ""))
 295                (setq ans (semantic-format-tag-type anything color)))
 296            ans))
 297         ((and (listp anything)
 298               (stringp (car anything)))
 299          (semantic--format-colorize-text (car anything) colorhint))))
 300
 301 (defun semantic-format-tag-name-default (tag &optional parent color)
 302   "Return an abbreviated string describing TAG.
 303 Optional argument PARENT is the parent type if TAG is a detail.
 304 Optional argument COLOR means highlight the prototype with font-lock colors."
 305   (let ((name (semantic-tag-name tag))
 306         (destructor
 307          (if (eq (semantic-tag-class tag) 'function)
 308              (semantic-tag-function-destructor-p tag))))
 309     (when destructor
 310       (setq name (concat "~" name)))
 311     (if color
 312         (setq name (semantic--format-colorize-text name (semantic-tag-class tag))))
 313     name))
 314
 315 (declare-function semantic-go-to-tag "semantic/tag-file")
 316
 317 (defun semantic--format-tag-parent-tree (tag parent)
 318   "Under Consideration.
 319
 320 Return a list of parents for TAG.
 321 PARENT is the first parent, or nil.  If nil, then an attempt to
 322 determine PARENT is made.
 323 Once PARENT is identified, additional parents are looked for.
 324 The return list first element is the nearest parent, and the last
 325 item is the first parent which may be a string.  The root parent may
 326 not be the actual first parent as there may just be a failure to find
 327 local definitions."
 328   ;; First, validate the PARENT argument.
 329   (unless parent
 330     ;; All mechanisms here must be fast as often parent
 331     ;; is nil because there isn't one.
 332     (setq parent (or (semantic-tag-function-parent tag)
 333                      (save-excursion
 334                        (require 'semantic/tag-file)
 335                        (semantic-go-to-tag tag)
 336                        (semantic-current-tag-parent)))))
 337   (when (stringp parent)
 338     (setq parent (semantic-find-first-tag-by-name
 339                   parent (current-buffer))))
 340   ;; Try and find a trail of parents from PARENT
 341   (let ((rlist (list parent))
 342         )
 343     ;; IMPLELEMENT ME!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 344     (reverse rlist)))
 345
 346 (define-overloadable-function semantic-format-tag-canonical-name (tag &optional parent color)
 347   "Return a canonical name for TAG.
 348 A canonical name includes the names of any parents or namespaces preceeding
 349 the tag.
 350 Optional argument PARENT is the parent type if TAG is a detail.
 351 Optional argument COLOR means highlight the prototype with font-lock colors.")
 352
 353 (defun semantic-format-tag-canonical-name-default (tag &optional parent color)
 354   "Return a canonical name for TAG.
 355 A canonical name includes the names of any parents or namespaces preceeding
 356 the tag with colons separating them.
 357 Optional argument PARENT is the parent type if TAG is a detail.
 358 Optional argument COLOR means highlight the prototype with font-lock colors."
 359   (let ((parent-input-str
 360          (if (and parent
 361                   (semantic-tag-p parent)
 362                   (semantic-tag-of-class-p parent 'type))
 363              (concat
 364               ;; Choose a class of 'type as the default parent for something.
 365               ;; Just a guess though.
 366               (semantic-format-tag-name-from-anything parent nil color 'type)
 367               ;; Default separator between class/namespace and others.
 368               semantic-format-parent-separator)
 369            ""))
 370         (tag-parent-str
 371          (or (when (and (semantic-tag-of-class-p tag 'function)
 372                         (semantic-tag-function-parent tag))
 373                (concat (semantic-tag-function-parent tag)
 374                        semantic-format-parent-separator))
 375              ""))
 376         )
 377     (concat parent-input-str
 378             tag-parent-str
 379             (semantic-format-tag-name tag parent color))
 380     ))
 381
 382 (define-overloadable-function semantic-format-tag-abbreviate (tag &optional parent color)
 383   "Return an abbreviated string describing TAG.
 384 The abbreviation is to be short, with possible symbols indicating
 385 the type of tag, or other information.
 386 Optional argument PARENT is the parent type if TAG is a detail.
 387 Optional argument COLOR means highlight the prototype with font-lock colors.")
 388
 389 (defun semantic-format-tag-abbreviate-default (tag &optional parent color)
 390   "Return an abbreviated string describing TAG.
 391 Optional argument PARENT is a parent tag in the tag hierarchy.
 392 In this case PARENT refers to containment, not inheritance.
 393 Optional argument COLOR means highlight the prototype with font-lock colors.
 394 This is a simple C like default."
 395   ;; Do lots of complex stuff here.
 396   (let ((class (semantic-tag-class tag))
 397         (name (semantic-format-tag-canonical-name tag parent color))
 398         (suffix "")
 399         (prefix "")
 400         str)
 401     (cond ((eq class 'function)
 402            (setq suffix "()"))
 403           ((eq class 'include)
 404            (setq suffix "<>"))
 405           ((eq class 'variable)
 406            (setq suffix (if (semantic-tag-variable-default tag)
 407                             "=" "")))
 408           ((eq class 'label)
 409            (setq suffix ":"))
 410           ((eq class 'code)
 411            (setq prefix "{"
 412                  suffix "}"))
 413           ((eq class 'type)
 414            (setq suffix "{}"))
 415           )
 416     (setq str (concat prefix name suffix))
 417     str))
 418
 419 ;; Semantic 1.2.x had this misspelling.  Keep it for backwards compatibiity.
 420 (semantic-alias-obsolete
 421  'semantic-summerize-nonterminal 'semantic-format-tag-summarize)
 422
 423 (define-overloadable-function semantic-format-tag-summarize (tag &optional parent color)
 424   "Summarize TAG in a reasonable way.
 425 Optional argument PARENT is the parent type if TAG is a detail.
 426 Optional argument COLOR means highlight the prototype with font-lock colors.")
 427
 428 (defun semantic-format-tag-summarize-default (tag &optional parent color)
 429   "Summarize TAG in a reasonable way.
 430 Optional argument PARENT is the parent type if TAG is a detail.
 431 Optional argument COLOR means highlight the prototype with font-lock colors."
 432   (let* ((proto (semantic-format-tag-prototype tag nil color))
 433          (names (if parent
 434                     semantic-symbol->name-assoc-list-for-type-parts
 435                   semantic-symbol->name-assoc-list))
 436          (tsymb (semantic-tag-class tag))
 437          (label (capitalize (or (cdr-safe (assoc tsymb names))
 438                                 (symbol-name tsymb)))))
 439     (if color
 440         (setq label (semantic--format-colorize-text label 'label)))
 441     (concat label ": " proto)))
 442
 443 (define-overloadable-function semantic-format-tag-summarize-with-file (tag &optional parent color)
 444   "Like `semantic-format-tag-summarize', but with the file name.
 445 Optional argument PARENT is the parent type if TAG is a detail.
 446 Optional argument COLOR means highlight the prototype with font-lock colors.")
 447
 448 (defun semantic-format-tag-summarize-with-file-default (tag &optional parent color)
 449   "Summarize TAG in a reasonable way.
 450 Optional argument PARENT is the parent type if TAG is a detail.
 451 Optional argument COLOR means highlight the prototype with font-lock colors."
 452   (let* ((proto (semantic-format-tag-prototype tag nil color))
 453          (file (semantic-tag-file-name tag))
 454          )
 455     ;; Nothing for tag?  Try parent.
 456     (when (and (not file) (and parent))
 457       (setq file (semantic-tag-file-name parent)))
 458     ;; Don't include the file name if we can't find one, or it is the
 459     ;; same as the current buffer.
 460     (if (or (not file)
 461             (string= file (buffer-file-name (current-buffer))))
 462         proto
 463       (setq file (file-name-nondirectory file))
 464       (when color
 465         (setq file (semantic--format-colorize-text file 'label)))
 466       (concat file ": " proto))))
 467
 468 (define-overloadable-function semantic-format-tag-short-doc (tag &optional parent color)
 469   "Display a short form of TAG's documentation. (Comments, or docstring.)
 470 Optional argument PARENT is the parent type if TAG is a detail.
 471 Optional argument COLOR means highlight the prototype with font-lock colors.")
 472
 473 (declare-function semantic-documentation-for-tag "semantic/doc")
 474
 475 (defun semantic-format-tag-short-doc-default (tag &optional parent color)
 476   "Display a short form of TAG's documentation.  (Comments, or docstring.)
 477 Optional argument PARENT is the parent type if TAG is a detail.
 478 Optional argument COLOR means highlight the prototype with font-lock colors."
 479
 480   (let* ((fname (or (semantic-tag-file-name tag)
 481                     (when parent (semantic-tag-file-name parent))))
 482          (buf (or (semantic-tag-buffer tag)
 483                   (when parent (semantic-tag-buffer parent))))
 484          (doc (semantic-tag-docstring tag buf)))
 485     (when (and (not doc) (not buf) fname)
 486       ;; If there is no doc, and no buffer, but we have a filename,
 487       ;; lets try again.
 488       (setq buf (find-file-noselect fname))
 489       (setq doc (semantic-tag-docstring tag buf)))
 490     (when (not doc)
 491       (require 'semantic/doc)
 492       (setq doc (semantic-documentation-for-tag tag))
 493       )
 494     (setq doc
 495           (if (not doc)
 496               ;; No doc, use summarize.
 497               (semantic-format-tag-summarize tag parent color)
 498             ;; We have doc.  Can we devise a single line?
 499             (if (string-match "$" doc)
 500                 (substring doc 0 (match-beginning 0))
 501               doc)
 502             ))
 503     (when color
 504       (setq doc (semantic--format-colorize-text doc 'documentation)))
 505     doc
 506     ))
 507
 508 ;;; Prototype generation
 509 ;;
 510 (defun semantic-format-tag-prototype-default (tag &optional parent color)
 511   "Default method for returning a prototype for TAG.
 512 This will work for C like languages.
 513 Optional argument PARENT is the parent type if TAG is a detail.
 514 Optional argument COLOR means highlight the prototype with font-lock colors."
 515   (let* ((class (semantic-tag-class tag))
 516          (name (semantic-format-tag-name tag parent color))
 517          (type (if (member class '(function variable type))
 518                    (semantic-format-tag-type tag color)))
 519          (args (if (member class '(function type))
 520                    (semantic--format-tag-arguments
 521                     (if (eq class 'function)
 522                         (semantic-tag-function-arguments tag)
 523                       (list "")
 524                       ;;(semantic-tag-type-members tag)
 525                       )
 526                     #'semantic-format-tag-prototype
 527                     color)))
 528          (const (semantic-tag-get-attribute tag :constant-flag))
 529          (tm (semantic-tag-get-attribute tag :typemodifiers))
 530          (mods (append
 531                 (if const '("const") nil)
 532                 (cond ((stringp tm) (list tm))
 533                       ((consp tm) tm)
 534                       (t nil))
 535                 ))
 536          (array (if (eq class 'variable)
 537                     (let ((deref
 538                            (semantic-tag-get-attribute
 539                             tag :dereference))
 540                           (r ""))
 541                       (while (and deref (/= deref 0))
 542                         (setq r (concat r "[]")
 543                               deref (1- deref)))
 544                       r)))
 545          )
 546     (if args
 547         (setq args
 548               (concat " "
 549                       (if (eq class 'type) "{" "(")
 550                       args
 551                       (if (eq class 'type) "}" ")"))))
 552     (when mods
 553       (setq mods (concat (mapconcat 'identity mods " ") " ")))
 554     (concat (or mods "")
 555             (if type (concat type " "))
 556             name
 557             (or args "")
 558             (or array ""))))
 559
 560 (define-overloadable-function semantic-format-tag-concise-prototype (tag &optional parent color)
 561   "Return a concise prototype for TAG.
 562 Optional argument PARENT is the parent type if TAG is a detail.
 563 Optional argument COLOR means highlight the prototype with font-lock colors.")
 564
 565 (defun semantic-format-tag-concise-prototype-default (tag &optional parent color)
 566   "Return a concise prototype for TAG.
 567 This default function will make a cheap concise prototype using C like syntax.
 568 Optional argument PARENT is the parent type if TAG is a detail.
 569 Optional argument COLOR means highlight the prototype with font-lock colors."
 570   (let ((class (semantic-tag-class tag)))
 571     (cond
 572      ((eq class 'type)
 573       (concat (semantic-format-tag-name tag parent color) "{}"))
 574      ((eq class 'function)
 575       (concat (semantic-format-tag-name tag parent color)
 576               " ("
 577               (semantic--format-tag-arguments
 578                (semantic-tag-function-arguments tag)
 579                'semantic-format-tag-concise-prototype
 580                color)
 581               ")"))
 582      ((eq class 'variable)
 583       (let* ((deref (semantic-tag-get-attribute
 584                      tag :dereference))
 585              (array "")
 586              )
 587         (while (and deref (/= deref 0))
 588           (setq array (concat array "[]")
 589                 deref (1- deref)))
 590         (concat (semantic-format-tag-name tag parent color)
 591                 array)))
 592      (t
 593       (semantic-format-tag-abbreviate tag parent color)))))
 594
 595 ;;; UML display styles
 596 ;;
 597 (defcustom semantic-uml-colon-string " : "
 598   "*String used as a color separator between parts of a UML string.
 599 In UML, a variable may appear as `varname : type'.
 600 Change this variable to change the output separator."
 601   :group 'semantic
 602   :type 'string)
 603
 604 (defcustom semantic-uml-no-protection-string ""
 605   "*String used to describe when no protection is specified.
 606 Used by `semantic-format-tag-uml-protection-to-string'."
 607   :group 'semantic
 608   :type 'string)
 609
 610 (defun semantic--format-uml-post-colorize (text tag parent)
 611   "Add color to TEXT created from TAG and PARENT.
 612 Adds augmentation for `abstract' and `static' entries."
 613   (if (semantic-tag-abstract-p tag parent)
 614       (setq text (semantic--format-colorize-merge-text text 'abstract)))
 615   (if (semantic-tag-static-p tag parent)
 616       (setq text (semantic--format-colorize-merge-text text 'static)))
 617   text
 618   )
 619
 620 (defun semantic-uml-attribute-string (tag &optional parent)
 621   "Return a string for TAG, a child of PARENT representing a UML attribute.
 622 UML attribute strings are things like {abstract} or {leaf}."
 623   (cond ((semantic-tag-abstract-p tag parent)
 624          "{abstract}")
 625         ((semantic-tag-leaf-p tag parent)
 626          "{leaf}")
 627         ))
 628
 629 (defvar semantic-format-tag-protection-image-alist
 630   '(("+" . ezimage-unlock)
 631     ("#" . ezimage-key)
 632     ("-" . ezimage-lock)
 633     )
 634   "Association of protection strings, and images to use.")
 635
 636 (defvar semantic-format-tag-protection-symbol-to-string-assoc-list
 637   '((public . "+")
 638     (protected . "#")
 639     (private . "-")
 640     )
 641   "Association list of the form (SYMBOL . \"STRING\") for protection symbols.
 642 This associates a symbol, such as 'public with the st ring \"+\".")
 643
 644 (define-overloadable-function semantic-format-tag-uml-protection-to-string (protection-symbol color)
 645   "Convert PROTECTION-SYMBOL to a string for UML.
 646 By default, uses `semantic-format-tag-protection-symbol-to-string-assoc-list'
 647 to convert.
 648 By defaul character returns are:
 649   public    -- +
 650   private   -- -
 651   protected -- #.
 652 If PROTECTION-SYMBOL is unknown, then the return value is
 653 `semantic-uml-no-protection-string'.
 654 COLOR indicates if we should use an image on the text.")
 655
 656 (defun semantic-format-tag-uml-protection-to-string-default (protection-symbol color)
 657   "Convert PROTECTION-SYMBOL to a string for UML.
 658 Uses `semantic-format-tag-protection-symbol-to-string-assoc-list' to convert.
 659 If PROTECTION-SYMBOL is unknown, then the return value is
 660 `semantic-uml-no-protection-string'.
 661 COLOR indicates if we should use an image on the text."
 662   (let* ((ezimage-use-images (and semantic-format-use-images-flag color))
 663          (key (assoc protection-symbol
 664                      semantic-format-tag-protection-symbol-to-string-assoc-list))
 665          (str (or (cdr-safe key) semantic-uml-no-protection-string)))
 666     (ezimage-image-over-string
 667      (copy-sequence str)  ; make a copy to keep the original pristine.
 668      semantic-format-tag-protection-image-alist)))
 669
 670 (defsubst semantic-format-tag-uml-protection (tag parent color)
 671   "Retrieve the protection string for TAG with PARENT.
 672 Argument COLOR specifies that color should be added to the string as
 673 needed."
 674   (semantic-format-tag-uml-protection-to-string
 675    (semantic-tag-protection tag parent)
 676    color))
 677
 678 (defun semantic--format-tag-uml-type (tag color)
 679   "Format the data type of TAG to a string usable for formatting.
 680 COLOR indicates if it should be colorized."
 681   (let ((str (semantic-format-tag-type tag color)))
 682     (if str
 683         (concat semantic-uml-colon-string str))))
 684
 685 (define-overloadable-function semantic-format-tag-uml-abbreviate (tag &optional parent color)
 686   "Return a UML style abbreviation for TAG.
 687 Optional argument PARENT is the parent type if TAG is a detail.
 688 Optional argument COLOR means highlight the prototype with font-lock colors.")
 689
 690 (defun semantic-format-tag-uml-abbreviate-default (tag &optional parent color)
 691   "Return a UML style abbreviation for TAG.
 692 Optional argument PARENT is the parent type if TAG is a detail.
 693 Optional argument COLOR means highlight the prototype with font-lock colors."
 694   (let* ((name (semantic-format-tag-name tag parent color))
 695          (type  (semantic--format-tag-uml-type tag color))
 696          (protstr (semantic-format-tag-uml-protection tag parent color))
 697          (text nil))
 698     (setq text
 699           (concat
 700            protstr
 701            (if type (concat name type)
 702              name)))
 703     (if color
 704         (setq text (semantic--format-uml-post-colorize text tag parent)))
 705     text))
 706
 707 (define-overloadable-function semantic-format-tag-uml-prototype (tag &optional parent color)
 708   "Return a UML style prototype for TAG.
 709 Optional argument PARENT is the parent type if TAG is a detail.
 710 Optional argument COLOR means highlight the prototype with font-lock colors.")
 711
 712 (defun semantic-format-tag-uml-prototype-default (tag &optional parent color)
 713   "Return a UML style prototype for TAG.
 714 Optional argument PARENT is the parent type if TAG is a detail.
 715 Optional argument COLOR means highlight the prototype with font-lock colors."
 716   (let* ((class (semantic-tag-class tag))
 717          (cp (semantic-format-tag-name tag parent color))
 718          (type (semantic--format-tag-uml-type tag color))
 719          (prot (semantic-format-tag-uml-protection tag parent color))
 720          (argtext
 721           (cond ((eq class 'function)
 722                  (concat
 723                   " ("
 724                   (semantic--format-tag-arguments
 725                    (semantic-tag-function-arguments tag)
 726                    #'semantic-format-tag-uml-prototype
 727                    color)
 728                   ")"))
 729                 ((eq class 'type)
 730                  "{}")))
 731          (text nil))
 732     (setq text (concat prot cp argtext type))
 733     (if color
 734         (setq text (semantic--format-uml-post-colorize text tag parent)))
 735     text
 736     ))
 737
 738 (define-overloadable-function semantic-format-tag-uml-concise-prototype (tag &optional parent color)
 739   "Return a UML style concise prototype for TAG.
 740 Optional argument PARENT is the parent type if TAG is a detail.
 741 Optional argument COLOR means highlight the prototype with font-lock colors.")
 742
 743 (defun semantic-format-tag-uml-concise-prototype-default (tag &optional parent color)
 744   "Return a UML style concise prototype for TAG.
 745 Optional argument PARENT is the parent type if TAG is a detail.
 746 Optional argument COLOR means highlight the prototype with font-lock colors."
 747   (let* ((cp (semantic-format-tag-concise-prototype tag parent color))
 748          (type (semantic--format-tag-uml-type tag color))
 749          (prot (semantic-format-tag-uml-protection tag parent color))
 750          (text nil)
 751          )
 752     (setq text (concat prot cp type))
 753     (if color
 754         (setq text (semantic--format-uml-post-colorize text tag parent)))
 755     text
 756     ))
 757
 758 \f
 759 ;;; Compatibility and aliases
 760 ;;
 761 (semantic-alias-obsolete 'semantic-prin1-nonterminal
 762                          'semantic-format-tag-prin1)
 763
 764 (semantic-alias-obsolete 'semantic-name-nonterminal
 765                          'semantic-format-tag-name)
 766
 767 (semantic-alias-obsolete 'semantic-abbreviate-nonterminal
 768                          'semantic-format-tag-abbreviate)
 769
 770 (semantic-alias-obsolete 'semantic-summarize-nonterminal
 771                          'semantic-format-tag-summarize)
 772
 773 (semantic-alias-obsolete 'semantic-prototype-nonterminal
 774                          'semantic-format-tag-prototype)
 775
 776 (semantic-alias-obsolete 'semantic-concise-prototype-nonterminal
 777                          'semantic-format-tag-concise-prototype)
 778
 779 (semantic-alias-obsolete 'semantic-uml-abbreviate-nonterminal
 780                          'semantic-format-tag-uml-abbreviate)
 781
 782 (semantic-alias-obsolete 'semantic-uml-prototype-nonterminal
 783                          'semantic-format-tag-uml-prototype)
 784
 785 (semantic-alias-obsolete 'semantic-uml-concise-prototype-nonterminal
 786                          'semantic-format-tag-uml-concise-prototype)
 787
 788
 789 (provide 'semantic/format)
 790
 791 ;; Local variables:
 792 ;; generated-autoload-file: "loaddefs.el"
 793 ;; generated-autoload-feature: semantic/loaddefs
 794 ;; End:
 795
 796 ;;; semantic/format.el ends here