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