cgit.sxemacs.org Git - packages/blob - xemacs-packages/semantic/semantic-format.el

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