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