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
  74 (defvar semantic-format-tag-custom-list
  75   (append '(radio)
  76           (mapcar (lambda (f) (list 'const f))
  77                   semantic-format-tag-functions)
  78           '(function))
  79   "A List used by customizeable variables to choose a tag to text function.
  80 Use this variable in the :type field of a customizable variable.")
  81
  82 (semantic-varalias-obsolete 'semantic-token->text-custom-list
  83                             'semantic-format-tag-custom-list)
  84
  85 (defcustom semantic-format-use-images-flag ezimage-use-images
  86   "Non-nil means semantic format functions use images.
  87 Images can be used as icons instead of some types of text strings."
  88   :group 'semantic
  89   :type 'boolean)
  90
  91 (defvar semantic-function-argument-separator ","
  92   "Text used to separate arguments when creating text from tags.")
  93 (make-variable-buffer-local 'semantic-function-argument-separator)
  94
  95 (defvar semantic-format-parent-separator "::"
  96   "Text used to separate names when between namespaces/classes and functions.")
  97 (make-variable-buffer-local 'semantic-format-parent-separator)
  98
  99 ;;;###autoload
 100 (define-overloadable-function semantic-format-tag-name (tag &optional parent color)
 101   "Return the name string describing TAG.
 102 The name is the shortest possible representation.
 103 Optional argument PARENT is the parent type if TAG is a detail.
 104 Optional argument COLOR means highlight the prototype with font-lock colors.")
 105
 106 ;;;###autoload
 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 ;;;###autoload
 424 (define-overloadable-function semantic-format-tag-summarize (tag &optional parent color)
 425   "Summarize TAG in a reasonable way.
 426 Optional argument PARENT is the parent type if TAG is a detail.
 427 Optional argument COLOR means highlight the prototype with font-lock colors.")
 428
 429 (defun semantic-format-tag-summarize-default (tag &optional parent color)
 430   "Summarize TAG in a reasonable way.
 431 Optional argument PARENT is the parent type if TAG is a detail.
 432 Optional argument COLOR means highlight the prototype with font-lock colors."
 433   (let* ((proto (semantic-format-tag-prototype tag nil color))
 434          (names (if parent
 435                     semantic-symbol->name-assoc-list-for-type-parts
 436                   semantic-symbol->name-assoc-list))
 437          (tsymb (semantic-tag-class tag))
 438          (label (capitalize (or (cdr-safe (assoc tsymb names))
 439                                 (symbol-name tsymb)))))
 440     (if color
 441         (setq label (semantic--format-colorize-text label 'label)))
 442     (concat label ": " proto)))
 443
 444 (define-overloadable-function semantic-format-tag-summarize-with-file (tag &optional parent color)
 445   "Like `semantic-format-tag-summarize', but with the file name.
 446 Optional argument PARENT is the parent type if TAG is a detail.
 447 Optional argument COLOR means highlight the prototype with font-lock colors.")
 448
 449 (defun semantic-format-tag-summarize-with-file-default (tag &optional parent color)
 450   "Summarize TAG in a reasonable way.
 451 Optional argument PARENT is the parent type if TAG is a detail.
 452 Optional argument COLOR means highlight the prototype with font-lock colors."
 453   (let* ((proto (semantic-format-tag-prototype tag nil color))
 454          (file (semantic-tag-file-name tag))
 455          )
 456     ;; Nothing for tag?  Try parent.
 457     (when (and (not file) (and parent))
 458       (setq file (semantic-tag-file-name parent)))
 459     ;; Don't include the file name if we can't find one, or it is the
 460     ;; same as the current buffer.
 461     (if (or (not file)
 462             (string= file (buffer-file-name (current-buffer))))
 463         proto
 464       (setq file (file-name-nondirectory file))
 465       (when color
 466         (setq file (semantic--format-colorize-text file 'label)))
 467       (concat file ": " proto))))
 468
 469 (define-overloadable-function semantic-format-tag-short-doc (tag &optional parent color)
 470   "Display a short form of TAG's documentation. (Comments, or docstring.)
 471 Optional argument PARENT is the parent type if TAG is a detail.
 472 Optional argument COLOR means highlight the prototype with font-lock colors.")
 473
 474 (declare-function semantic-documentation-for-tag "semantic/doc")
 475
 476 (defun semantic-format-tag-short-doc-default (tag &optional parent color)
 477   "Display a short form of TAG's documentation.  (Comments, or docstring.)
 478 Optional argument PARENT is the parent type if TAG is a detail.
 479 Optional argument COLOR means highlight the prototype with font-lock colors."
 480
 481   (let* ((fname (or (semantic-tag-file-name tag)
 482                     (when parent (semantic-tag-file-name parent))))
 483          (buf (or (semantic-tag-buffer tag)
 484                   (when parent (semantic-tag-buffer parent))))
 485          (doc (semantic-tag-docstring tag buf)))
 486     (when (and (not doc) (not buf) fname)
 487       ;; If there is no doc, and no buffer, but we have a filename,
 488       ;; lets try again.
 489       (setq buf (find-file-noselect fname))
 490       (setq doc (semantic-tag-docstring tag buf)))
 491     (when (not doc)
 492       (require 'semantic/doc)
 493       (setq doc (semantic-documentation-for-tag tag))
 494       )
 495     (setq doc
 496           (if (not doc)
 497               ;; No doc, use summarize.
 498               (semantic-format-tag-summarize tag parent color)
 499             ;; We have doc.  Can we devise a single line?
 500             (if (string-match "$" doc)
 501                 (substring doc 0 (match-beginning 0))
 502               doc)
 503             ))
 504     (when color
 505       (setq doc (semantic--format-colorize-text doc 'documentation)))
 506     doc
 507     ))
 508
 509 ;;; Prototype generation
 510 ;;
 511 (defun semantic-format-tag-prototype-default (tag &optional parent color)
 512   "Default method for returning a prototype for TAG.
 513 This will work for C like languages.
 514 Optional argument PARENT is the parent type if TAG is a detail.
 515 Optional argument COLOR means highlight the prototype with font-lock colors."
 516   (let* ((class (semantic-tag-class tag))
 517          (name (semantic-format-tag-name tag parent color))
 518          (type (if (member class '(function variable type))
 519                    (semantic-format-tag-type tag color)))
 520          (args (if (member class '(function type))
 521                    (semantic--format-tag-arguments
 522                     (if (eq class 'function)
 523                         (semantic-tag-function-arguments tag)
 524                       (list "")
 525                       ;;(semantic-tag-type-members tag)
 526                       )
 527                     #'semantic-format-tag-prototype
 528                     color)))
 529          (const (semantic-tag-get-attribute tag :constant-flag))
 530          (tm (semantic-tag-get-attribute tag :typemodifiers))
 531          (mods (append
 532                 (if const '("const") nil)
 533                 (cond ((stringp tm) (list tm))
 534                       ((consp tm) tm)
 535                       (t nil))
 536                 ))
 537          (array (if (eq class 'variable)
 538                     (let ((deref
 539                            (semantic-tag-get-attribute
 540                             tag :dereference))
 541                           (r ""))
 542                       (while (and deref (/= deref 0))
 543                         (setq r (concat r "[]")
 544                               deref (1- deref)))
 545                       r)))
 546          )
 547     (if args
 548         (setq args
 549               (concat " "
 550                       (if (eq class 'type) "{" "(")
 551                       args
 552                       (if (eq class 'type) "}" ")"))))
 553     (when mods
 554       (setq mods (concat (mapconcat 'identity mods " ") " ")))
 555     (concat (or mods "")
 556             (if type (concat type " "))
 557             name
 558             (or args "")
 559             (or array ""))))
 560
 561 ;;;###autoload
 562 (define-overloadable-function semantic-format-tag-concise-prototype (tag &optional parent color)
 563   "Return a concise prototype for TAG.
 564 Optional argument PARENT is the parent type if TAG is a detail.
 565 Optional argument COLOR means highlight the prototype with font-lock colors.")
 566
 567 (defun semantic-format-tag-concise-prototype-default (tag &optional parent color)
 568   "Return a concise prototype for TAG.
 569 This default function will make a cheap concise prototype using C like syntax.
 570 Optional argument PARENT is the parent type if TAG is a detail.
 571 Optional argument COLOR means highlight the prototype with font-lock colors."
 572   (let ((class (semantic-tag-class tag)))
 573     (cond
 574      ((eq class 'type)
 575       (concat (semantic-format-tag-name tag parent color) "{}"))
 576      ((eq class 'function)
 577       (concat (semantic-format-tag-name tag parent color)
 578               " ("
 579               (semantic--format-tag-arguments
 580                (semantic-tag-function-arguments tag)
 581                'semantic-format-tag-concise-prototype
 582                color)
 583               ")"))
 584      ((eq class 'variable)
 585       (let* ((deref (semantic-tag-get-attribute
 586                      tag :dereference))
 587              (array "")
 588              )
 589         (while (and deref (/= deref 0))
 590           (setq array (concat array "[]")
 591                 deref (1- deref)))
 592         (concat (semantic-format-tag-name tag parent color)
 593                 array)))
 594      (t
 595       (semantic-format-tag-abbreviate tag parent color)))))
 596
 597 ;;; UML display styles
 598 ;;
 599 (defcustom semantic-uml-colon-string " : "
 600   "*String used as a color separator between parts of a UML string.
 601 In UML, a variable may appear as `varname : type'.
 602 Change this variable to change the output separator."
 603   :group 'semantic
 604   :type 'string)
 605
 606 (defcustom semantic-uml-no-protection-string ""
 607   "*String used to describe when no protection is specified.
 608 Used by `semantic-format-tag-uml-protection-to-string'."
 609   :group 'semantic
 610   :type 'string)
 611
 612 (defun semantic--format-uml-post-colorize (text tag parent)
 613   "Add color to TEXT created from TAG and PARENT.
 614 Adds augmentation for `abstract' and `static' entries."
 615   (if (semantic-tag-abstract-p tag parent)
 616       (setq text (semantic--format-colorize-merge-text text 'abstract)))
 617   (if (semantic-tag-static-p tag parent)
 618       (setq text (semantic--format-colorize-merge-text text 'static)))
 619   text
 620   )
 621
 622 (defun semantic-uml-attribute-string (tag &optional parent)
 623   "Return a string for TAG, a child of PARENT representing a UML attribute.
 624 UML attribute strings are things like {abstract} or {leaf}."
 625   (cond ((semantic-tag-abstract-p tag parent)
 626          "{abstract}")
 627         ((semantic-tag-leaf-p tag parent)
 628          "{leaf}")
 629         ))
 630
 631 (defvar semantic-format-tag-protection-image-alist
 632   '(("+" . ezimage-unlock)
 633     ("#" . ezimage-key)
 634     ("-" . ezimage-lock)
 635     )
 636   "Association of protection strings, and images to use.")
 637
 638 (defvar semantic-format-tag-protection-symbol-to-string-assoc-list
 639   '((public . "+")
 640     (protected . "#")
 641     (private . "-")
 642     )
 643   "Association list of the form (SYMBOL . \"STRING\") for protection symbols.
 644 This associates a symbol, such as 'public with the st ring \"+\".")
 645
 646 (define-overloadable-function semantic-format-tag-uml-protection-to-string (protection-symbol color)
 647   "Convert PROTECTION-SYMBOL to a string for UML.
 648 By default, uses `semantic-format-tag-protection-symbol-to-string-assoc-list'
 649 to convert.
 650 By defaul character returns are:
 651   public    -- +
 652   private   -- -
 653   protected -- #.
 654 If PROTECTION-SYMBOL is unknown, then the return value is
 655 `semantic-uml-no-protection-string'.
 656 COLOR indicates if we should use an image on the text.")
 657
 658 (defun semantic-format-tag-uml-protection-to-string-default (protection-symbol color)
 659   "Convert PROTECTION-SYMBOL to a string for UML.
 660 Uses `semantic-format-tag-protection-symbol-to-string-assoc-list' to convert.
 661 If PROTECTION-SYMBOL is unknown, then the return value is
 662 `semantic-uml-no-protection-string'.
 663 COLOR indicates if we should use an image on the text."
 664   (let* ((ezimage-use-images (and semantic-format-use-images-flag color))
 665          (key (assoc protection-symbol
 666                      semantic-format-tag-protection-symbol-to-string-assoc-list))
 667          (str (or (cdr-safe key) semantic-uml-no-protection-string)))
 668     (ezimage-image-over-string
 669      (copy-sequence str)  ; make a copy to keep the original pristine.
 670      semantic-format-tag-protection-image-alist)))
 671
 672 (defsubst semantic-format-tag-uml-protection (tag parent color)
 673   "Retrieve the protection string for TAG with PARENT.
 674 Argument COLOR specifies that color should be added to the string as
 675 needed."
 676   (semantic-format-tag-uml-protection-to-string
 677    (semantic-tag-protection tag parent)
 678    color))
 679
 680 (defun semantic--format-tag-uml-type (tag color)
 681   "Format the data type of TAG to a string usable for formatting.
 682 COLOR indicates if it should be colorized."
 683   (let ((str (semantic-format-tag-type tag color)))
 684     (if str
 685         (concat semantic-uml-colon-string str))))
 686
 687 (define-overloadable-function semantic-format-tag-uml-abbreviate (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
 692 (defun semantic-format-tag-uml-abbreviate-default (tag &optional parent color)
 693   "Return a UML style abbreviation for TAG.
 694 Optional argument PARENT is the parent type if TAG is a detail.
 695 Optional argument COLOR means highlight the prototype with font-lock colors."
 696   (let* ((name (semantic-format-tag-name tag parent color))
 697          (type  (semantic--format-tag-uml-type tag color))
 698          (protstr (semantic-format-tag-uml-protection tag parent color))
 699          (text nil))
 700     (setq text
 701           (concat
 702            protstr
 703            (if type (concat name type)
 704              name)))
 705     (if color
 706         (setq text (semantic--format-uml-post-colorize text tag parent)))
 707     text))
 708
 709 (define-overloadable-function semantic-format-tag-uml-prototype (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
 714 (defun semantic-format-tag-uml-prototype-default (tag &optional parent color)
 715   "Return a UML style prototype for TAG.
 716 Optional argument PARENT is the parent type if TAG is a detail.
 717 Optional argument COLOR means highlight the prototype with font-lock colors."
 718   (let* ((class (semantic-tag-class tag))
 719          (cp (semantic-format-tag-name tag parent color))
 720          (type (semantic--format-tag-uml-type tag color))
 721          (prot (semantic-format-tag-uml-protection tag parent color))
 722          (argtext
 723           (cond ((eq class 'function)
 724                  (concat
 725                   " ("
 726                   (semantic--format-tag-arguments
 727                    (semantic-tag-function-arguments tag)
 728                    #'semantic-format-tag-uml-prototype
 729                    color)
 730                   ")"))
 731                 ((eq class 'type)
 732                  "{}")))
 733          (text nil))
 734     (setq text (concat prot cp argtext type))
 735     (if color
 736         (setq text (semantic--format-uml-post-colorize text tag parent)))
 737     text
 738     ))
 739
 740 (define-overloadable-function semantic-format-tag-uml-concise-prototype (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
 745 (defun semantic-format-tag-uml-concise-prototype-default (tag &optional parent color)
 746   "Return a UML style concise prototype for TAG.
 747 Optional argument PARENT is the parent type if TAG is a detail.
 748 Optional argument COLOR means highlight the prototype with font-lock colors."
 749   (let* ((cp (semantic-format-tag-concise-prototype tag parent color))
 750          (type (semantic--format-tag-uml-type tag color))
 751          (prot (semantic-format-tag-uml-protection tag parent color))
 752          (text nil)
 753          )
 754     (setq text (concat prot cp type))
 755     (if color
 756         (setq text (semantic--format-uml-post-colorize text tag parent)))
 757     text
 758     ))
 759
 760 \f
 761 ;;; Compatibility and aliases
 762 ;;
 763 (semantic-alias-obsolete 'semantic-prin1-nonterminal
 764                          'semantic-format-tag-prin1)
 765
 766 (semantic-alias-obsolete 'semantic-name-nonterminal
 767                          'semantic-format-tag-name)
 768
 769 (semantic-alias-obsolete 'semantic-abbreviate-nonterminal
 770                          'semantic-format-tag-abbreviate)
 771
 772 (semantic-alias-obsolete 'semantic-summarize-nonterminal
 773                          'semantic-format-tag-summarize)
 774
 775 (semantic-alias-obsolete 'semantic-prototype-nonterminal
 776                          'semantic-format-tag-prototype)
 777
 778 (semantic-alias-obsolete 'semantic-concise-prototype-nonterminal
 779                          'semantic-format-tag-concise-prototype)
 780
 781 (semantic-alias-obsolete 'semantic-uml-abbreviate-nonterminal
 782                          'semantic-format-tag-uml-abbreviate)
 783
 784 (semantic-alias-obsolete 'semantic-uml-prototype-nonterminal
 785                          'semantic-format-tag-uml-prototype)
 786
 787 (semantic-alias-obsolete 'semantic-uml-concise-prototype-nonterminal
 788                          'semantic-format-tag-uml-concise-prototype)
 789
 790
 791 (provide 'semantic/format)
 792
 793 ;; Local variables:
 794 ;; generated-autoload-file: "loaddefs.el"
 795 ;; generated-autoload-feature: semantic/loaddefs
 796 ;; generated-autoload-load-name: "semantic/format"
 797 ;; End:
 798
 799 ;;; semantic/format.el ends here