1 ;;; sort.el --- Utilities for sorting and re-arranging tag tables.
3 ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
4 ;;; 2008, 2009 Free Software Foundation, Inc.
6 ;; Author: Eric M. Ludlam <zappo@gnu.org>
9 ;; This file is part of GNU Emacs.
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.
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.
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/>.
26 ;; Tag tables originate in the order they appear in a buffer, or source file.
27 ;; It is often useful to re-arrange them is some predictable way for browsing
28 ;; purposes. Re-organization may be alphabetical, or even a complete
29 ;; reorganization of parents and children.
31 ;; Originally written in semantic-util.el
36 (require 'semantic/db)
38 (require 'semantic/find)
39 (require 'semantic/db-find))
41 ;;; Alphanumeric sorting
43 ;; Takes a list of tags, and sorts them in a case-insensitive way
47 (defun semantic-string-lessp-ci (s1 s2)
48 "Case insensitive version of `string-lessp'.
49 Argument S1 and S2 are the strings to compare."
50 ;; Use downcase instead of upcase because an average name
51 ;; has more lower case characters.
52 (if (fboundp 'compare-strings)
53 (eq (compare-strings s1 0 nil s2 0 nil t) -1)
54 (string-lessp (downcase s1) (downcase s2))))
56 (defun semantic-sort-tag-type (tag)
57 "Return a type string for TAG guaranteed to be a string."
58 (let ((ty (semantic-tag-type tag)))
65 (defun semantic-tag-lessp-name-then-type (A B)
66 "Return t if tag A is < tag B.
67 First sorts on name, then sorts on the name of the :type of
69 (let ((na (semantic-tag-name A))
70 (nb (semantic-tag-name B))
72 (if (string-lessp na nb)
75 ;; If equal, test the :type which might be different.
76 (let* ((ta (semantic-tag-type A))
77 (tb (semantic-tag-type B))
78 (tas (cond ((stringp ta)
81 (semantic-tag-name ta))
83 (tbs (cond ((stringp tb)
86 (semantic-tag-name tb))
88 (if (and (stringp tas) (stringp tbs))
90 ;; This is if A == B, and no types in A or B
92 ;; This nil is if A > B, but not =
95 (defun semantic-sort-tags-by-name-increasing (tags)
96 "Sort TAGS by name in increasing order with side effects.
97 Return the sorted list."
98 (sort tags (lambda (a b)
99 (string-lessp (semantic-tag-name a)
100 (semantic-tag-name b)))))
102 (defun semantic-sort-tags-by-name-decreasing (tags)
103 "Sort TAGS by name in decreasing order with side effects.
104 Return the sorted list."
105 (sort tags (lambda (a b)
106 (string-lessp (semantic-tag-name b)
107 (semantic-tag-name a)))))
109 (defun semantic-sort-tags-by-type-increasing (tags)
110 "Sort TAGS by type in increasing order with side effects.
111 Return the sorted list."
112 (sort tags (lambda (a b)
113 (string-lessp (semantic-sort-tag-type a)
114 (semantic-sort-tag-type b)))))
116 (defun semantic-sort-tags-by-type-decreasing (tags)
117 "Sort TAGS by type in decreasing order with side effects.
118 Return the sorted list."
119 (sort tags (lambda (a b)
120 (string-lessp (semantic-sort-tag-type b)
121 (semantic-sort-tag-type a)))))
123 (defun semantic-sort-tags-by-name-increasing-ci (tags)
124 "Sort TAGS by name in increasing order with side effects.
125 Return the sorted list."
126 (sort tags (lambda (a b)
127 (semantic-string-lessp-ci (semantic-tag-name a)
128 (semantic-tag-name b)))))
130 (defun semantic-sort-tags-by-name-decreasing-ci (tags)
131 "Sort TAGS by name in decreasing order with side effects.
132 Return the sorted list."
133 (sort tags (lambda (a b)
134 (semantic-string-lessp-ci (semantic-tag-name b)
135 (semantic-tag-name a)))))
137 (defun semantic-sort-tags-by-type-increasing-ci (tags)
138 "Sort TAGS by type in increasing order with side effects.
139 Return the sorted list."
140 (sort tags (lambda (a b)
141 (semantic-string-lessp-ci (semantic-sort-tag-type a)
142 (semantic-sort-tag-type b)))))
144 (defun semantic-sort-tags-by-type-decreasing-ci (tags)
145 "Sort TAGS by type in decreasing order with side effects.
146 Return the sorted list."
147 (sort tags (lambda (a b)
148 (semantic-string-lessp-ci (semantic-sort-tag-type b)
149 (semantic-sort-tag-type a)))))
151 (defun semantic-sort-tags-by-name-then-type-increasing (tags)
152 "Sort TAGS by name, then type in increasing order with side effects.
153 Return the sorted list."
154 (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type a b))))
156 (defun semantic-sort-tags-by-name-then-type-decreasing (tags)
157 "Sort TAGS by name, then type in increasing order with side effects.
158 Return the sorted list."
159 (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type b a))))
162 (semantic-alias-obsolete 'semantic-sort-tokens-by-name-increasing
163 'semantic-sort-tags-by-name-increasing)
164 (semantic-alias-obsolete 'semantic-sort-tokens-by-name-decreasing
165 'semantic-sort-tags-by-name-decreasing)
166 (semantic-alias-obsolete 'semantic-sort-tokens-by-type-increasing
167 'semantic-sort-tags-by-type-increasing)
168 (semantic-alias-obsolete 'semantic-sort-tokens-by-type-decreasing
169 'semantic-sort-tags-by-type-decreasing)
170 (semantic-alias-obsolete 'semantic-sort-tokens-by-name-increasing-ci
171 'semantic-sort-tags-by-name-increasing-ci)
172 (semantic-alias-obsolete 'semantic-sort-tokens-by-name-decreasing-ci
173 'semantic-sort-tags-by-name-decreasing-ci)
174 (semantic-alias-obsolete 'semantic-sort-tokens-by-type-increasing-ci
175 'semantic-sort-tags-by-type-increasing-ci)
176 (semantic-alias-obsolete 'semantic-sort-tokens-by-type-decreasing-ci
177 'semantic-sort-tags-by-type-decreasing-ci)
182 ;; Scan a list of tags, removing duplicates.
183 ;; This must first sort the tags by name alphabetically ascending.
185 ;; Useful for completion lists, or other situations where the
186 ;; other data isn't as useful.
188 (defun semantic-unique-tag-table-by-name (tags)
189 "Scan a list of TAGS, removing duplicate names.
190 This must first sort the tags by name alphabetically ascending.
191 For more complex uniqueness testing used by the semanticdb
192 typecaching system, see `semanticdb-typecache-merge-streams'."
193 (let ((sorted (semantic-sort-tags-by-name-increasing
194 (copy-sequence tags)))
198 (not (string= (semantic-tag-name (car sorted))
199 (semantic-tag-name (car uniq)))))
200 (setq uniq (cons (car sorted) uniq)))
201 (setq sorted (cdr sorted))
205 (defun semantic-unique-tag-table (tags)
206 "Scan a list of TAGS, removing duplicates.
207 This must first sort the tags by position ascending.
208 TAGS are removed only if they are equivalent, as can happen when
209 multiple tag sources are scanned.
210 For more complex uniqueness testing used by the semanticdb
211 typecaching system, see `semanticdb-typecache-merge-streams'."
212 (let ((sorted (sort (copy-sequence tags)
214 (cond ((not (semantic-tag-with-position-p a))
216 ((not (semantic-tag-with-position-p b))
219 (< (semantic-tag-start a)
220 (semantic-tag-start b)))))))
224 (not (semantic-equivalent-tag-p (car sorted) (car uniq))))
225 (setq uniq (cons (car sorted) uniq)))
226 (setq sorted (cdr sorted))
231 ;;; Tag Table Flattening
233 ;; In the 1.4 search API, there was a parameter "search-parts" which
234 ;; was used to find tags inside other tags. This was used
235 ;; infrequently, mostly for completion/jump routines. These types
236 ;; of commands would be better off with a flattened list, where all
237 ;; tags appear at the top level.
239 (defun semantic-flatten-tags-table (&optional table)
240 "Flatten the tags table TABLE.
241 All tags in TABLE, and all components of top level tags
242 in TABLE will appear at the top level of list.
243 Tags promoted to the top of the list will still appear
244 unmodified as components of their parent tags."
245 (let* ((table (semantic-something-to-tag-table table))
246 ;; Initialize the starting list with our table.
247 (lists (list table)))
249 (let ((components (semantic-tag-components tag)))
251 ;; unpositined tags can be hazardous to
252 ;; completion. Do we need any type of tag
254 (semantic-tag-with-position-p (car components)))
256 (semantic-flatten-tags-table components)
259 (apply 'append (nreverse lists))
265 ;; A list of tags can be grouped into buckets based on the tag class.
266 ;; Bucketize means to take a list of tags at a given level in a tag
267 ;; table, and reorganize them into buckets based on class.
269 (defvar semantic-bucketize-tag-class
270 ;; Must use lambda because `semantic-tag-class' is a macro.
271 (lambda (tok) (semantic-tag-class tok))
272 "Function used to get a symbol describing the class of a tag.
273 This function must take one argument of a semantic tag.
274 It should return a symbol found in `semantic-symbol->name-assoc-list'
275 which `semantic-bucketize' uses to bin up tokens.
276 To create new bins for an application augment
277 `semantic-symbol->name-assoc-list', and
278 `semantic-symbol->name-assoc-list-for-type-parts' in addition
279 to setting this variable (locally in your function).")
281 (defun semantic-bucketize (tags &optional parent filter)
282 "Sort TAGS into a group of buckets based on tag class.
283 Unknown classes are placed in a Misc bucket.
284 Type bucket names are defined by either `semantic-symbol->name-assoc-list'.
285 If PARENT is specified, then TAGS belong to this PARENT in some way.
286 This will use `semantic-symbol->name-assoc-list-for-type-parts' to
287 generate bucket names.
288 Optional argument FILTER is a filter function to be applied to each bucket.
289 The filter function will take one argument, which is a list of tokens, and
290 may re-organize the list with side-effects."
291 (let* ((name-list (if parent
292 semantic-symbol->name-assoc-list-for-type-parts
293 semantic-symbol->name-assoc-list))
295 (bins (make-vector (1+ (length sn)) nil))
300 ;; Build up the bucket vector
302 (setq nsn (cons (cons (car (car sn)) num) nsn)
305 ;; Place into buckets
307 (setq tagtype (funcall semantic-bucketize-tag-class (car tags))
308 ask (assq tagtype nsn)
309 num (or (cdr ask) 0))
310 (aset bins num (cons (car tags) (aref bins num)))
311 (setq tags (cdr tags)))
312 ;; Remove from buckets into a list.
314 (while (< num (length bins))
315 (when (aref bins num)
318 (cdr (nth (1- num) name-list))
319 ;; Filtering, First hacked by David Ponce david@dponce.com
320 (funcall (or filter 'nreverse) (aref bins num)))
324 (setq out (cons (cons "Misc"
325 (funcall (or filter 'nreverse) (aref bins 0)))
331 ;; Some languages allow children of a type to be defined outside
332 ;; the syntactic scope of that class. These routines will find those
333 ;; external members, and bring them together in a cloned copy of the
336 (defvar semantic-orphaned-member-metaparent-type "class"
337 "In `semantic-adopt-external-members', the type of 'type for metaparents.
338 A metaparent is a made-up type semantic token used to hold the child list
339 of orphaned members of a named type.")
340 (make-variable-buffer-local 'semantic-orphaned-member-metaparent-type)
342 (defvar semantic-mark-external-member-function nil
343 "Function called when an externally defined orphan is found.
344 By default, the token is always marked with the `adopted' property.
345 This function should be locally bound by a program that needs
346 to add additional behaviors into the token list.
347 This function is called with two arguments. The first is TOKEN which is
348 a shallow copy of the token to be modified. The second is the PARENT
349 which is adopting TOKEN. This function should return TOKEN (or a copy of it)
350 which is then integrated into the revised token list.")
352 (defun semantic-adopt-external-members (tags)
353 "Rebuild TAGS so that externally defined members are regrouped.
354 Some languages such as C++ and CLOS permit the declaration of member
355 functions outside the definition of the class. It is easier to study
356 the structure of a program when such methods are grouped together
359 This function uses `semantic-tag-external-member-p' to
360 determine when a potential child is an externally defined member.
362 Note: Applications which use this function must account for token
363 types which do not have a position, but have children which *do*
366 Applications should use `semantic-mark-external-member-function'
367 to modify all tags which are found as externally defined to some
368 type. For example, changing the token type for generating extra
369 buckets with the bucket function."
370 (let ((parent-buckets nil)
375 ;; Rebuild the output list, stripping out all parented
379 ((setq tmp (semantic-tag-external-member-parent (car tags)))
380 (let ((tagcopy (semantic-tag-clone (car tags)))
381 (a (assoc tmp parent-buckets)))
382 (semantic--tag-put-property-no-side-effect tagcopy 'adopted t)
384 ;; If this parent is already in the list, append.
385 (setcdr (nthcdr (1- (length a)) a) (list tagcopy))
386 ;; If not, prepend this new parent bucket into our list
388 (cons (cons tmp (list tagcopy)) parent-buckets)))
390 ((eq (semantic-tag-class (car tags)) 'type)
391 ;; Types need to be rebuilt from scratch so we can add in new
392 ;; children to the child list. Only the top-level cons
393 ;; cells need to be duplicated so we can hack out the
395 (setq out (cons (semantic-tag-clone (car tags)) out))
396 (setq decent-list (cons (car out) decent-list))
399 ;; Otherwise, append this tag to our new output list.
400 (setq out (cons (car tags) out)))
402 (setq tags (cdr tags)))
403 ;; Rescan out, by descending into all types and finding parents
404 ;; for all entries moved into the parent-buckets.
406 (let* ((bucket (assoc (semantic-tag-name (car decent-list))
408 (bucketkids (cdr bucket)))
410 ;; Run our secondary marking function on the children
411 (if semantic-mark-external-member-function
413 (mapcar (lambda (tok)
414 (funcall semantic-mark-external-member-function
415 tok (car decent-list)))
417 ;; We have some extra kids. Merge.
418 (semantic-tag-put-attribute
419 (car decent-list) :members
420 (append (semantic-tag-type-members (car decent-list))
422 ;; Nuke the bucket label so it is not found again.
425 (append (cdr decent-list)
426 ;; get embedded types to scan and make copies
429 (lambda (tok) (semantic-tag-clone tok))
430 (semantic-find-tags-by-class 'type
431 (semantic-tag-type-members (car decent-list)))))
433 ;; Scan over all remaining lost external methods, and tack them
435 (while parent-buckets
436 (if (car (car parent-buckets))
437 (let* ((tmp (car parent-buckets))
438 (fauxtag (semantic-tag-new-type
440 semantic-orphaned-member-metaparent-type
442 nil ;; parents (unknown)
444 (bucketkids (cdr tmp)))
445 (semantic-tag-set-faux fauxtag) ;; properties
446 (if semantic-mark-external-member-function
448 (mapcar (lambda (tok)
449 (funcall semantic-mark-external-member-function
452 (semantic-tag-put-attribute fauxtag :members bucketkids)
453 ;; We have a bunch of methods with no parent in this file.
454 ;; Create a meta-type to hold it.
455 (setq out (cons fauxtag out))
457 (setq parent-buckets (cdr parent-buckets)))
458 ;; Return the new list.
462 ;;; External children
464 ;; In order to adopt external children, we need a few overload methods
465 ;; to enable the feature.
467 (define-overloadable-function semantic-tag-external-member-parent (tag)
468 "Return a parent for TAG when TAG is an external member.
469 TAG is an external member if it is defined at a toplevel and
470 has some sort of label defining a parent. The parent return will
473 The default behavior, if not overridden with
474 `tag-member-parent' gets the 'parent extra
477 If this function is overridden, use
478 `semantic-tag-external-member-parent-default' to also
479 include the default behavior, and merely extend your own."
482 (defun semantic-tag-external-member-parent-default (tag)
483 "Return the name of TAGs parent only if TAG is not defined in it's parent."
484 ;; Use only the extra spec because a type has a parent which
485 ;; means something completely different.
486 (let ((tp (semantic-tag-get-attribute tag :parent)))
491 (semantic-alias-obsolete 'semantic-nonterminal-external-member-parent
492 'semantic-tag-external-member-parent)
494 (define-overloadable-function semantic-tag-external-member-p (parent tag)
495 "Return non-nil if PARENT is the parent of TAG.
496 TAG is an external member of PARENT when it is somehow tagged
497 as having PARENT as it's parent.
498 PARENT and TAG must both be semantic tags.
500 The default behavior, if not overridden with
501 `tag-external-member-p' is to match :parent attribute in
504 If this function is overridden, use
505 `semantic-tag-external-member-children-p-default' to also
506 include the default behavior, and merely extend your own."
509 (defun semantic-tag-external-member-p-default (parent tag)
510 "Return non-nil if PARENT is the parent of TAG."
511 ;; Use only the extra spec because a type has a parent which
512 ;; means something completely different.
513 (let ((tp (semantic-tag-external-member-parent tag)))
515 (string= (semantic-tag-name parent) tp))
518 (semantic-alias-obsolete 'semantic-nonterminal-external-member-p
519 'semantic-tag-external-member-p)
521 (define-overloadable-function semantic-tag-external-member-children (tag &optional usedb)
522 "Return the list of children which are not *in* TAG.
523 If optional argument USEDB is non-nil, then also search files in
524 the Semantic Database. If USEDB is a list of databases, search those
527 Children in this case are functions or types which are members of
528 TAG, such as the parts of a type, but which are not defined inside
529 the class. C++ and CLOS both permit methods of a class to be defined
530 outside the bounds of the class' definition.
532 The default behavior, if not overridden with
533 `tag-external-member-children' is to search using
534 `semantic-tag-external-member-p' in all top level definitions
535 with a parent of TAG.
537 If this function is overridden, use
538 `semantic-tag-external-member-children-default' to also
539 include the default behavior, and merely extend your own."
542 (defun semantic-tag-external-member-children-default (tag &optional usedb)
543 "Return list of external children for TAG.
544 Optional argument USEDB specifies if the semantic database is used.
545 See `semantic-tag-external-member-children' for details."
547 (fboundp 'semanticdb-minor-mode-p)
548 (semanticdb-minor-mode-p))
549 (let ((m (semanticdb-find-tags-external-children-of-type
550 (semantic-tag-name tag))))
551 (if m (apply #'append (mapcar #'cdr m))))
552 (semantic--find-tags-by-function
554 ;; This bit of annoying backquote forces the contents of
555 ;; tag into the generated lambda.
556 (semantic-tag-external-member-p ',tag tok))
560 (define-overloadable-function semantic-tag-external-class (tag)
561 "Return a list of real tags that faux TAG might represent.
563 In some languages, a method can be defined on an object which is
564 not in the same file. In this case,
565 `semantic-adopt-external-members' will create a faux-tag. If it
566 is necessary to get the tag from which for faux TAG was most
567 likely derived, then this function is needed."
568 (unless (semantic-tag-faux-p tag)
569 (signal 'wrong-type-argument (list tag 'semantic-tag-faux-p)))
573 (defun semantic-tag-external-class-default (tag)
574 "Return a list of real tags that faux TAG might represent.
575 See `semantic-tag-external-class' for details."
576 (if (and (fboundp 'semanticdb-minor-mode-p)
577 (semanticdb-minor-mode-p))
578 (let* ((semanticdb-search-system-databases nil)
579 (m (semanticdb-find-tags-by-class
580 (semantic-tag-class tag)
581 (semanticdb-find-tags-by-name (semantic-tag-name tag)))))
582 (semanticdb-strip-find-results m 'name))
583 ;; Presumably, if the tag is faux, it is not local.
587 (semantic-alias-obsolete 'semantic-nonterminal-external-member-children
588 'semantic-tag-external-member-children)
590 (provide 'semantic/sort)
592 ;;; semantic-sort.el ends here