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-ls)
  38 (require 'ezimage)
  39
  40 (eval-when-compile
  41   (require 'font-lock)
  42   (require 'semantic/find))
  43
  44 ;;; Tag to text overload functions
  45 ;;
  46 ;; abbreviations, prototypes, and coloring support.
  47 (defvar semantic-format-tag-functions
  48   '(semantic-format-tag-name
  49     semantic-format-tag-canonical-name
  50     semantic-format-tag-abbreviate
  51     semantic-format-tag-summarize
  52     semantic-format-tag-summarize-with-file
  53     semantic-format-tag-short-doc
  54     semantic-format-tag-prototype
  55     semantic-format-tag-concise-prototype
  56     semantic-format-tag-uml-abbreviate
  57     semantic-format-tag-uml-prototype
  58     semantic-format-tag-uml-concise-prototype
  59     semantic-format-tag-prin1
  60     )
  61   "List of functions which convert a tag to text.
  62 Each function must take the parameters TAG &optional PARENT COLOR.
  63 TAG is the tag to convert.
  64 PARENT is a parent tag or name which refers to the structure
  65 or class which contains TAG.  PARENT is NOT a class which a TAG
  66 would claim as a parent.
  67 COLOR indicates that the generated text should be colored using
  68 `font-lock'.")
  69
  70 (semantic-varalias-obsolete 'semantic-token->text-functions
  71                             'semantic-format-tag-functions)
  72
  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 ;;;###autoload
  99 (define-overloadable-function semantic-format-tag-name (tag &optional parent color)
 100   "Return the name string describing TAG.
 101 The name is the shortest possible representation.
 102 Optional argument PARENT is the parent type if TAG is a detail.
 103 Optional argument COLOR means highlight the prototype with font-lock colors.")
 104
 105 (defun semantic-format-tag-name-default (tag &optional parent color)
 106   "Return an abbreviated string describing TAG.
 107 Optional argument PARENT is the parent type if TAG is a detail.
 108 Optional argument COLOR means highlight the prototype with font-lock colors."
 109   (let ((name (semantic-tag-name tag))
 110         (destructor
 111          (if (eq (semantic-tag-class tag) 'function)
 112              (semantic-tag-function-destructor-p tag))))
 113     (when destructor
 114       (setq name (concat "~" name)))
 115     (if color
 116         (setq name (semantic--format-colorize-text name (semantic-tag-class tag))))
 117     name))
 118
 119 ;;;###autoload
 120 (define-overloadable-function semantic-format-tag-prototype (tag &optional parent color)
 121   "Return a prototype for TAG.
 122 This function should be overloaded, though it need not be used.
 123 This is because it can be used to create code by language independent
 124 tools.
 125 Optional argument PARENT is the parent type if TAG is a detail.
 126 Optional argument COLOR means highlight the prototype with font-lock colors.")
 127
 128
 129 (defun semantic-test-all-format-tag-functions (&optional arg)
 130   "Test all outputs from `semantic-format-tag-functions'.
 131 Output is generated from the function under `point'.
 132 Optional argument ARG specifies not to use color."
 133   (interactive "P")
 134   (require 'semantic/find)
 135   (semantic-fetch-tags)
 136   (let* ((tag (semantic-current-tag))
 137          (par (semantic-current-tag-parent))
 138          (fns semantic-format-tag-functions))
 139     (with-output-to-temp-buffer "*format-tag*"
 140       (princ "Tag->format function tests:")
 141       (while fns
 142         (princ "\n")
 143         (princ (car fns))
 144         (princ ":\n ")
 145         (let ((s (funcall (car fns) tag par (not arg))))
 146           (save-excursion
 147             (set-buffer "*format-tag*")
 148             (goto-char (point-max))
 149             (insert s)))
 150         (setq fns (cdr fns))))
 151       ))
 152
 153 (defvar semantic-format-face-alist
 154   `( (function . font-lock-function-name-face)
 155      (variable . font-lock-variable-name-face)
 156      (type . font-lock-type-face)
 157      ;; These are different between Emacsen.
 158      (include . ,(if (featurep 'xemacs)
 159                      'font-lock-preprocessor-face
 160                    'font-lock-constant-face))
 161      (package . ,(if (featurep 'xemacs)
 162                      'font-lock-preprocessor-face
 163                    'font-lock-constant-face))
 164      ;; Not a tag, but instead a feature of output
 165      (label . font-lock-string-face)
 166      (comment . font-lock-comment-face)
 167      (keyword . font-lock-keyword-face)
 168      (abstract . italic)
 169      (static . underline)
 170      (documentation . font-lock-doc-face)
 171      )
 172   "Face used to colorize tags of different types.
 173 Override the value locally if a language supports other tag types.
 174 When adding new elements, try to use symbols also returned by the parser.
 175 The form of an entry in this list is of the form:
 176  ( SYMBOL .  FACE )
 177 where SYMBOL is a tag type symbol used with semantic.  FACE
 178 is a symbol representing a face.
 179 Faces used are generated in `font-lock' for consistency, and will not
 180 be used unless font lock is a feature.")
 181
 182 (semantic-varalias-obsolete 'semantic-face-alist
 183                             'semantic-format-face-alist)
 184
 185
 186 \f
 187 ;;; Coloring Functions
 188 ;;
 189 (defun semantic--format-colorize-text (text face-class)
 190   "Apply onto TEXT a color associated with FACE-CLASS.
 191 FACE-CLASS is a tag type found in `semantic-face-alist'.  See this variable
 192 for details on adding new types."
 193   (if (featurep 'font-lock)
 194       (let ((face (cdr-safe (assoc face-class semantic-format-face-alist)))
 195             (newtext (concat text)))
 196         (put-text-property 0 (length text) 'face face newtext)
 197         newtext)
 198     text))
 199
 200 (make-obsolete 'semantic-colorize-text
 201                'semantic--format-colorize-text)
 202
 203 (defun semantic--format-colorize-merge-text (precoloredtext face-class)
 204   "Apply onto PRECOLOREDTEXT a color associated with FACE-CLASS.
 205 FACE-CLASS is a tag type found in 'semantic-face-alist'.  See this
 206 variable for details on adding new types."
 207   (let ((face (cdr-safe (assoc face-class semantic-format-face-alist)))
 208         (newtext (concat precoloredtext))
 209         )
 210     (if (featurep 'xemacs)
 211         (add-text-properties 0 (length newtext) (list 'face face) newtext)
 212       (alter-text-property 0 (length newtext) 'face
 213                            (lambda (current-face)
 214                              (let ((cf
 215                                     (cond ((facep current-face)
 216                                            (list current-face))
 217                                           ((listp current-face)
 218                                            current-face)
 219                                           (t nil)))
 220                                    (nf
 221                                     (cond ((facep face)
 222                                            (list face))
 223                                           ((listp face)
 224                                            face)
 225                                           (t nil))))
 226                                (append cf nf)))
 227                            newtext))
 228     newtext))
 229
 230 ;;; Function Arguments
 231 ;;
 232 (defun semantic--format-tag-arguments (args formatter color)
 233   "Format the argument list ARGS with FORMATTER.
 234 FORMATTER is a function used to format a tag.
 235 COLOR specifies if color should be used."
 236   (let ((out nil))
 237     (while args
 238       (push (if (and formatter
 239                      (semantic-tag-p (car args))
 240                      (not (string= (semantic-tag-name (car args)) ""))
 241                      )
 242                 (funcall formatter (car args) nil color)
 243               (semantic-format-tag-name-from-anything
 244                (car args) nil color 'variable))
 245             out)
 246       (setq args (cdr args)))
 247     (mapconcat 'identity (nreverse out) semantic-function-argument-separator)
 248     ))
 249
 250 ;;; Data Type
 251 (define-overloadable-function semantic-format-tag-type (tag color)
 252   "Convert the data type of TAG to a string usable in tag formatting.
 253 It is presumed that TYPE is a string or semantic tag.")
 254
 255 (defun semantic-format-tag-type-default (tag color)
 256   "Convert the data type of TAG to a string usable in tag formatting.
 257 Argument COLOR specifies to colorize the text."
 258   (let* ((type (semantic-tag-type tag))
 259          (out (cond ((semantic-tag-p type)
 260                      (let* ((typetype (semantic-tag-type type))
 261                             (name (semantic-tag-name type))
 262                             (str (if typetype
 263                                      (concat typetype " " name)
 264                                    name)))
 265                        (if color
 266                            (semantic--format-colorize-text
 267                             str
 268                             'type)
 269                          str)))
 270                     ((and (listp type)
 271                           (stringp (car type)))
 272                      (car type))
 273                     ((stringp type)
 274                      type)
 275                     (t nil))))
 276     (if (and color out)
 277         (setq out (semantic--format-colorize-text out 'type))
 278       out)
 279     ))
 280
 281 \f
 282 ;;; Abstract formatting functions
 283
 284 (defun semantic-format-tag-prin1 (tag &optional parent color)
 285   "Convert TAG to a string that is the print name for TAG.
 286 PARENT and COLOR are ignored."
 287   (format "%S" tag))
 288
 289 (defun semantic-format-tag-name-from-anything (anything &optional
 290                                                         parent color
 291                                                         colorhint)
 292   "Convert just about anything into a name like string.
 293 Argument ANYTHING is the thing to be converted.
 294 Optional argument PARENT is the parent type if TAG is a detail.
 295 Optional argument COLOR means highlight the prototype with font-lock colors.
 296 Optional COLORHINT is the type of color to use if ANYTHING is not a tag
 297 with a tag class.  See `semantic--format-colorize-text' for a definition
 298 of FACE-CLASS for which this is used."
 299   (cond ((stringp anything)
 300          (semantic--format-colorize-text anything colorhint))
 301         ((semantic-tag-p anything)
 302          (let ((ans (semantic-format-tag-name anything parent color)))
 303            ;; If ANS is empty string or nil, then the name wasn't
 304            ;; supplied.  The implication is as in C where there is a data
 305            ;; type but no name for a prototype from an include file, or
 306            ;; an argument just wasn't used in the body of the fcn.
 307            (if (or (null ans) (string= ans ""))
 308                (setq ans (semantic-format-tag-type anything color)))
 309            ans))
 310         ((and (listp anything)
 311               (stringp (car anything)))
 312          (semantic--format-colorize-text (car anything) colorhint))))
 313
 314 (declare-function semantic-go-to-tag "semantic/tag-file")
 315
 316 (defun semantic--format-tag-parent-tree (tag parent)
 317   "Under Consideration.
 318
 319 Return a list of parents for TAG.
 320 PARENT is the first parent, or nil.  If nil, then an attempt to
 321 determine PARENT is made.
 322 Once PARENT is identified, additional parents are looked for.
 323 The return list first element is the nearest parent, and the last
 324 item is the first parent which may be a string.  The root parent may
 325 not be the actual first parent as there may just be a failure to find
 326 local definitions."
 327   ;; First, validate the PARENT argument.
 328   (unless parent
 329     ;; All mechanisms here must be fast as often parent
 330     ;; is nil because there isn't one.
 331     (setq parent (or (semantic-tag-function-parent tag)
 332                      (save-excursion
 333                        (require 'semantic/tag-file)
 334                        (semantic-go-to-tag tag)
 335                        (semantic-current-tag-parent)))))
 336   (when (stringp parent)
 337     (setq parent (semantic-find-first-tag-by-name
 338                   parent (current-buffer))))
 339   ;; Try and find a trail of parents from PARENT
 340   (let ((rlist (list parent))
 341         )
 342     ;; IMPLELEMENT ME!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 343     (reverse rlist)))
 344
 345 (define-overloadable-function semantic-format-tag-canonical-name (tag &optional parent color)
 346   "Return a canonical name for TAG.
 347 A canonical name includes the names of any parents or namespaces preceeding
 348 the tag.
 349 Optional argument PARENT is the parent type if TAG is a detail.
 350 Optional argument COLOR means highlight the prototype with font-lock colors.")
 351
 352 (defun semantic-format-tag-canonical-name-default (tag &optional parent color)
 353   "Return a canonical name for TAG.
 354 A canonical name includes the names of any parents or namespaces preceeding
 355 the tag with colons separating them.
 356 Optional argument PARENT is the parent type if TAG is a detail.
 357 Optional argument COLOR means highlight the prototype with font-lock colors."
 358   (let ((parent-input-str
 359          (if (and parent
 360                   (semantic-tag-p parent)
 361                   (semantic-tag-of-class-p parent 'type))
 362              (concat
 363               ;; Choose a class of 'type as the default parent for something.
 364               ;; Just a guess though.
 365               (semantic-format-tag-name-from-anything parent nil color 'type)
 366               ;; Default separator between class/namespace and others.
 367               semantic-format-parent-separator)
 368            ""))
 369         (tag-parent-str
 370          (or (when (and (semantic-tag-of-class-p tag 'function)
 371                         (semantic-tag-function-parent tag))
 372                (concat (semantic-tag-function-parent tag)
 373                        semantic-format-parent-separator))
 374              ""))
 375         )
 376     (concat parent-input-str
 377             tag-parent-str
 378             (semantic-format-tag-name tag parent color))
 379     ))
 380
 381 (define-overloadable-function semantic-format-tag-abbreviate (tag &optional parent color)
 382   "Return an abbreviated string describing TAG.
 383 The abbreviation is to be short, with possible symbols indicating
 384 the type of tag, or other information.
 385 Optional argument PARENT is the parent type if TAG is a detail.
 386 Optional argument COLOR means highlight the prototype with font-lock colors.")
 387
 388 (defun semantic-format-tag-abbreviate-default (tag &optional parent color)
 389   "Return an abbreviated string describing TAG.
 390 Optional argument PARENT is a parent tag in the tag hierarchy.
 391 In this case PARENT refers to containment, not inheritance.
 392 Optional argument COLOR means highlight the prototype with font-lock colors.
 393 This is a simple C like default."
 394   ;; Do lots of complex stuff here.
 395   (let ((class (semantic-tag-class tag))
 396         (name (semantic-format-tag-canonical-name tag parent color))
 397         (suffix "")
 398         (prefix "")
 399         str)
 400     (cond ((eq class 'function)
 401            (setq suffix "()"))
 402           ((eq class 'include)
 403            (setq suffix "<>"))
 404           ((eq class 'variable)
 405            (setq suffix (if (semantic-tag-variable-default tag)
 406                             "=" "")))
 407           ((eq class 'label)
 408            (setq suffix ":"))
 409           ((eq class 'code)
 410            (setq prefix "{"
 411                  suffix "}"))
 412           ((eq class 'type)
 413            (setq suffix "{}"))
 414           )
 415     (setq str (concat prefix name suffix))
 416     str))
 417
 418 ;; Semantic 1.2.x had this misspelling.  Keep it for backwards compatibiity.
 419 (semantic-alias-obsolete
 420  'semantic-summerize-nonterminal 'semantic-format-tag-summarize)
 421
 422 ;;;###autoload
 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   (let* ((fname (or (semantic-tag-file-name tag)
 480                     (when parent (semantic-tag-file-name parent))))
 481          (buf (or (semantic-tag-buffer tag)
 482                   (when parent (semantic-tag-buffer parent))))
 483          (doc (semantic-tag-docstring tag buf)))
 484     (when (and (not doc) (not buf) fname)
 485       ;; If there is no doc, and no buffer, but we have a filename,
 486       ;; lets try again.
 487       (setq buf (find-file-noselect fname))
 488       (setq doc (semantic-tag-docstring tag buf)))
 489     (when (not doc)
 490       (require 'semantic/doc)
 491       (setq doc (semantic-documentation-for-tag tag))
 492       )
 493     (setq doc
 494           (if (not doc)
 495               ;; No doc, use summarize.
 496               (semantic-format-tag-summarize tag parent color)
 497             ;; We have doc.  Can we devise a single line?
 498             (if (string-match "$" doc)
 499                 (substring doc 0 (match-beginning 0))
 500               doc)
 501             ))
 502     (when color
 503       (setq doc (semantic--format-colorize-text doc 'documentation)))
 504     doc
 505     ))
 506
 507 ;;; Prototype generation
 508
 509 (defun semantic-format-tag-prototype-default (tag &optional parent color)
 510   "Default method for returning a prototype for TAG.
 511 This will work for C like languages.
 512 Optional argument PARENT is the parent type if TAG is a detail.
 513 Optional argument COLOR means highlight the prototype with font-lock colors."
 514   (let* ((class (semantic-tag-class tag))
 515          (name (semantic-format-tag-name tag parent color))
 516          (type (if (member class '(function variable type))
 517                    (semantic-format-tag-type tag color)))
 518          (args (if (member class '(function type))
 519                    (semantic--format-tag-arguments
 520                     (if (eq class 'function)
 521                         (semantic-tag-function-arguments tag)
 522                       (list "")
 523                       ;;(semantic-tag-type-members tag)
 524                       )
 525                     #'semantic-format-tag-prototype
 526                     color)))
 527          (const (semantic-tag-get-attribute tag :constant-flag))
 528          (tm (semantic-tag-get-attribute tag :typemodifiers))
 529          (mods (append
 530                 (if const '("const") nil)
 531                 (cond ((stringp tm) (list tm))
 532                       ((consp tm) tm)
 533                       (t nil))
 534                 ))
 535          (array (if (eq class 'variable)
 536                     (let ((deref
 537                            (semantic-tag-get-attribute
 538                             tag :dereference))
 539                           (r ""))
 540                       (while (and deref (/= deref 0))
 541                         (setq r (concat r "[]")
 542                               deref (1- deref)))
 543                       r)))
 544          )
 545     (if args
 546         (setq args
 547               (concat " "
 548                       (if (eq class 'type) "{" "(")
 549                       args
 550                       (if (eq class 'type) "}" ")"))))
 551     (when mods
 552       (setq mods (concat (mapconcat 'identity mods " ") " ")))
 553     (concat (or mods "")
 554             (if type (concat type " "))
 555             name
 556             (or args "")
 557             (or array ""))))
 558
 559 ;;;###autoload
 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 ;; generated-autoload-load-name: "semantic/format"
 795 ;; End:
 796
 797 ;;; semantic/format.el ends here