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