Mercurial > emacs
diff lisp/cedet/semantic/sort.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 | 2bf481006ba4 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/sort.el Fri Aug 28 19:18:35 2009 +0000 @@ -0,0 +1,592 @@ +;;; sort.el --- Utilities for sorting and re-arranging tag tables. + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, +;;; 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Tag tables originate in the order they appear in a buffer, or source file. +;; It is often useful to re-arrange them is some predictable way for browsing +;; purposes. Re-organization may be alphabetical, or even a complete +;; reorganization of parents and children. +;; +;; Originally written in semantic-util.el +;; + +(require 'assoc) +(require 'semantic) +(require 'semantic/db) +(eval-when-compile + (require 'semantic/find) + (require 'semantic/db-find)) + +;;; Alphanumeric sorting +;; +;; Takes a list of tags, and sorts them in a case-insensitive way +;; at a single level. + +;;; Code: +(defun semantic-string-lessp-ci (s1 s2) + "Case insensitive version of `string-lessp'. +Argument S1 and S2 are the strings to compare." + ;; Use downcase instead of upcase because an average name + ;; has more lower case characters. + (if (fboundp 'compare-strings) + (eq (compare-strings s1 0 nil s2 0 nil t) -1) + (string-lessp (downcase s1) (downcase s2)))) + +(defun semantic-sort-tag-type (tag) + "Return a type string for TAG guaranteed to be a string." + (let ((ty (semantic-tag-type tag))) + (cond ((stringp ty) + ty) + ((listp ty) + (or (car ty) "")) + (t "")))) + +(defun semantic-tag-lessp-name-then-type (A B) + "Return t if tag A is < tag B. +First sorts on name, then sorts on the name of the :type of +each tag." + (let ((na (semantic-tag-name A)) + (nb (semantic-tag-name B)) + ) + (if (string-lessp na nb) + t ; a sure thing. + (if (string= na nb) + ;; If equal, test the :type which might be different. + (let* ((ta (semantic-tag-type A)) + (tb (semantic-tag-type B)) + (tas (cond ((stringp ta) + ta) + ((semantic-tag-p ta) + (semantic-tag-name ta)) + (t nil))) + (tbs (cond ((stringp tb) + tb) + ((semantic-tag-p tb) + (semantic-tag-name tb)) + (t nil)))) + (if (and (stringp tas) (stringp tbs)) + (string< tas tbs) + ;; This is if A == B, and no types in A or B + nil)) + ;; This nil is if A > B, but not = + nil)))) + +(defun semantic-sort-tags-by-name-increasing (tags) + "Sort TAGS by name in increasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (string-lessp (semantic-tag-name a) + (semantic-tag-name b))))) + +(defun semantic-sort-tags-by-name-decreasing (tags) + "Sort TAGS by name in decreasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (string-lessp (semantic-tag-name b) + (semantic-tag-name a))))) + +(defun semantic-sort-tags-by-type-increasing (tags) + "Sort TAGS by type in increasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (string-lessp (semantic-sort-tag-type a) + (semantic-sort-tag-type b))))) + +(defun semantic-sort-tags-by-type-decreasing (tags) + "Sort TAGS by type in decreasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (string-lessp (semantic-sort-tag-type b) + (semantic-sort-tag-type a))))) + +(defun semantic-sort-tags-by-name-increasing-ci (tags) + "Sort TAGS by name in increasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (semantic-string-lessp-ci (semantic-tag-name a) + (semantic-tag-name b))))) + +(defun semantic-sort-tags-by-name-decreasing-ci (tags) + "Sort TAGS by name in decreasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (semantic-string-lessp-ci (semantic-tag-name b) + (semantic-tag-name a))))) + +(defun semantic-sort-tags-by-type-increasing-ci (tags) + "Sort TAGS by type in increasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (semantic-string-lessp-ci (semantic-sort-tag-type a) + (semantic-sort-tag-type b))))) + +(defun semantic-sort-tags-by-type-decreasing-ci (tags) + "Sort TAGS by type in decreasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (semantic-string-lessp-ci (semantic-sort-tag-type b) + (semantic-sort-tag-type a))))) + +(defun semantic-sort-tags-by-name-then-type-increasing (tags) + "Sort TAGS by name, then type in increasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type a b)))) + +(defun semantic-sort-tags-by-name-then-type-decreasing (tags) + "Sort TAGS by name, then type in increasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type b a)))) + + +(semantic-alias-obsolete 'semantic-sort-tokens-by-name-increasing + 'semantic-sort-tags-by-name-increasing) +(semantic-alias-obsolete 'semantic-sort-tokens-by-name-decreasing + 'semantic-sort-tags-by-name-decreasing) +(semantic-alias-obsolete 'semantic-sort-tokens-by-type-increasing + 'semantic-sort-tags-by-type-increasing) +(semantic-alias-obsolete 'semantic-sort-tokens-by-type-decreasing + 'semantic-sort-tags-by-type-decreasing) +(semantic-alias-obsolete 'semantic-sort-tokens-by-name-increasing-ci + 'semantic-sort-tags-by-name-increasing-ci) +(semantic-alias-obsolete 'semantic-sort-tokens-by-name-decreasing-ci + 'semantic-sort-tags-by-name-decreasing-ci) +(semantic-alias-obsolete 'semantic-sort-tokens-by-type-increasing-ci + 'semantic-sort-tags-by-type-increasing-ci) +(semantic-alias-obsolete 'semantic-sort-tokens-by-type-decreasing-ci + 'semantic-sort-tags-by-type-decreasing-ci) + + +;;; Unique +;; +;; Scan a list of tags, removing duplicates. +;; This must first sort the tags by name alphabetically ascending. +;; +;; Useful for completion lists, or other situations where the +;; other data isn't as useful. + +(defun semantic-unique-tag-table-by-name (tags) + "Scan a list of TAGS, removing duplicate names. +This must first sort the tags by name alphabetically ascending. +For more complex uniqueness testing used by the semanticdb +typecaching system, see `semanticdb-typecache-merge-streams'." + (let ((sorted (semantic-sort-tags-by-name-increasing + (copy-sequence tags))) + (uniq nil)) + (while sorted + (if (or (not uniq) + (not (string= (semantic-tag-name (car sorted)) + (semantic-tag-name (car uniq))))) + (setq uniq (cons (car sorted) uniq))) + (setq sorted (cdr sorted)) + ) + (nreverse uniq))) + +(defun semantic-unique-tag-table (tags) + "Scan a list of TAGS, removing duplicates. +This must first sort the tags by position ascending. +TAGS are removed only if they are equivalent, as can happen when +multiple tag sources are scanned. +For more complex uniqueness testing used by the semanticdb +typecaching system, see `semanticdb-typecache-merge-streams'." + (let ((sorted (sort (copy-sequence tags) + (lambda (a b) + (cond ((not (semantic-tag-with-position-p a)) + t) + ((not (semantic-tag-with-position-p b)) + nil) + (t + (< (semantic-tag-start a) + (semantic-tag-start b))))))) + (uniq nil)) + (while sorted + (if (or (not uniq) + (not (semantic-equivalent-tag-p (car sorted) (car uniq)))) + (setq uniq (cons (car sorted) uniq))) + (setq sorted (cdr sorted)) + ) + (nreverse uniq))) + + +;;; Tag Table Flattening +;; +;; In the 1.4 search API, there was a parameter "search-parts" which +;; was used to find tags inside other tags. This was used +;; infrequently, mostly for completion/jump routines. These types +;; of commands would be better off with a flattened list, where all +;; tags appear at the top level. + +(defun semantic-flatten-tags-table (&optional table) + "Flatten the tags table TABLE. +All tags in TABLE, and all components of top level tags +in TABLE will appear at the top level of list. +Tags promoted to the top of the list will still appear +unmodified as components of their parent tags." + (let* ((table (semantic-something-to-tag-table table)) + ;; Initialize the starting list with our table. + (lists (list table))) + (mapc (lambda (tag) + (let ((components (semantic-tag-components tag))) + (if (and components + ;; unpositined tags can be hazardous to + ;; completion. Do we need any type of tag + ;; here? - EL + (semantic-tag-with-position-p (car components))) + (setq lists (cons + (semantic-flatten-tags-table components) + lists))))) + table) + (apply 'append (nreverse lists)) + )) + + +;;; Buckets: +;; +;; A list of tags can be grouped into buckets based on the tag class. +;; Bucketize means to take a list of tags at a given level in a tag +;; table, and reorganize them into buckets based on class. +;; +(defvar semantic-bucketize-tag-class + ;; Must use lambda because `semantic-tag-class' is a macro. + (lambda (tok) (semantic-tag-class tok)) + "Function used to get a symbol describing the class of a tag. +This function must take one argument of a semantic tag. +It should return a symbol found in `semantic-symbol->name-assoc-list' +which `semantic-bucketize' uses to bin up tokens. +To create new bins for an application augment +`semantic-symbol->name-assoc-list', and +`semantic-symbol->name-assoc-list-for-type-parts' in addition +to setting this variable (locally in your function).") + +(defun semantic-bucketize (tags &optional parent filter) + "Sort TAGS into a group of buckets based on tag class. +Unknown classes are placed in a Misc bucket. +Type bucket names are defined by either `semantic-symbol->name-assoc-list'. +If PARENT is specified, then TAGS belong to this PARENT in some way. +This will use `semantic-symbol->name-assoc-list-for-type-parts' to +generate bucket names. +Optional argument FILTER is a filter function to be applied to each bucket. +The filter function will take one argument, which is a list of tokens, and +may re-organize the list with side-effects." + (let* ((name-list (if parent + semantic-symbol->name-assoc-list-for-type-parts + semantic-symbol->name-assoc-list)) + (sn name-list) + (bins (make-vector (1+ (length sn)) nil)) + ask tagtype + (nsn nil) + (num 1) + (out nil)) + ;; Build up the bucket vector + (while sn + (setq nsn (cons (cons (car (car sn)) num) nsn) + sn (cdr sn) + num (1+ num))) + ;; Place into buckets + (while tags + (setq tagtype (funcall semantic-bucketize-tag-class (car tags)) + ask (assq tagtype nsn) + num (or (cdr ask) 0)) + (aset bins num (cons (car tags) (aref bins num))) + (setq tags (cdr tags))) + ;; Remove from buckets into a list. + (setq num 1) + (while (< num (length bins)) + (when (aref bins num) + (setq out + (cons (cons + (cdr (nth (1- num) name-list)) + ;; Filtering, First hacked by David Ponce david@dponce.com + (funcall (or filter 'nreverse) (aref bins num))) + out))) + (setq num (1+ num))) + (if (aref bins 0) + (setq out (cons (cons "Misc" + (funcall (or filter 'nreverse) (aref bins 0))) + out))) + (nreverse out))) + +;;; Adoption +;; +;; Some languages allow children of a type to be defined outside +;; the syntactic scope of that class. These routines will find those +;; external members, and bring them together in a cloned copy of the +;; class tag. +;; +(defvar semantic-orphaned-member-metaparent-type "class" + "In `semantic-adopt-external-members', the type of 'type for metaparents. +A metaparent is a made-up type semantic token used to hold the child list +of orphaned members of a named type.") +(make-variable-buffer-local 'semantic-orphaned-member-metaparent-type) + +(defvar semantic-mark-external-member-function nil + "Function called when an externally defined orphan is found. +By default, the token is always marked with the `adopted' property. +This function should be locally bound by a program that needs +to add additional behaviors into the token list. +This function is called with two arguments. The first is TOKEN which is +a shallow copy of the token to be modified. The second is the PARENT +which is adopting TOKEN. This function should return TOKEN (or a copy of it) +which is then integrated into the revised token list.") + +(defun semantic-adopt-external-members (tags) + "Rebuild TAGS so that externally defined members are regrouped. +Some languages such as C++ and CLOS permit the declaration of member +functions outside the definition of the class. It is easier to study +the structure of a program when such methods are grouped together +more logically. + +This function uses `semantic-tag-external-member-p' to +determine when a potential child is an externally defined member. + +Note: Applications which use this function must account for token +types which do not have a position, but have children which *do* +have positions. + +Applications should use `semantic-mark-external-member-function' +to modify all tags which are found as externally defined to some +type. For example, changing the token type for generating extra +buckets with the bucket function." + (let ((parent-buckets nil) + (decent-list nil) + (out nil) + (tmp nil) + ) + ;; Rebuild the output list, stripping out all parented + ;; external entries + (while tags + (cond + ((setq tmp (semantic-tag-external-member-parent (car tags))) + (let ((tagcopy (semantic-tag-clone (car tags))) + (a (assoc tmp parent-buckets))) + (semantic--tag-put-property-no-side-effect tagcopy 'adopted t) + (if a + ;; If this parent is already in the list, append. + (setcdr (nthcdr (1- (length a)) a) (list tagcopy)) + ;; If not, prepend this new parent bucket into our list + (setq parent-buckets + (cons (cons tmp (list tagcopy)) parent-buckets))) + )) + ((eq (semantic-tag-class (car tags)) 'type) + ;; Types need to be rebuilt from scratch so we can add in new + ;; children to the child list. Only the top-level cons + ;; cells need to be duplicated so we can hack out the + ;; child list later. + (setq out (cons (semantic-tag-clone (car tags)) out)) + (setq decent-list (cons (car out) decent-list)) + ) + (t + ;; Otherwise, append this tag to our new output list. + (setq out (cons (car tags) out))) + ) + (setq tags (cdr tags))) + ;; Rescan out, by descending into all types and finding parents + ;; for all entries moved into the parent-buckets. + (while decent-list + (let* ((bucket (assoc (semantic-tag-name (car decent-list)) + parent-buckets)) + (bucketkids (cdr bucket))) + (when bucket + ;; Run our secondary marking function on the children + (if semantic-mark-external-member-function + (setq bucketkids + (mapcar (lambda (tok) + (funcall semantic-mark-external-member-function + tok (car decent-list))) + bucketkids))) + ;; We have some extra kids. Merge. + (semantic-tag-put-attribute + (car decent-list) :members + (append (semantic-tag-type-members (car decent-list)) + bucketkids)) + ;; Nuke the bucket label so it is not found again. + (setcar bucket nil)) + (setq decent-list + (append (cdr decent-list) + ;; get embedded types to scan and make copies + ;; of them. + (mapcar + (lambda (tok) (semantic-tag-clone tok)) + (semantic-find-tags-by-class 'type + (semantic-tag-type-members (car decent-list))))) + ))) + ;; Scan over all remaining lost external methods, and tack them + ;; onto the end. + (while parent-buckets + (if (car (car parent-buckets)) + (let* ((tmp (car parent-buckets)) + (fauxtag (semantic-tag-new-type + (car tmp) + semantic-orphaned-member-metaparent-type + nil ;; Part list + nil ;; parents (unknown) + )) + (bucketkids (cdr tmp))) + (semantic-tag-set-faux fauxtag) ;; properties + (if semantic-mark-external-member-function + (setq bucketkids + (mapcar (lambda (tok) + (funcall semantic-mark-external-member-function + tok fauxtag)) + bucketkids))) + (semantic-tag-put-attribute fauxtag :members bucketkids) + ;; We have a bunch of methods with no parent in this file. + ;; Create a meta-type to hold it. + (setq out (cons fauxtag out)) + )) + (setq parent-buckets (cdr parent-buckets))) + ;; Return the new list. + (nreverse out))) + + +;;; External children +;; +;; In order to adopt external children, we need a few overload methods +;; to enable the feature. +;; +(define-overloadable-function semantic-tag-external-member-parent (tag) + "Return a parent for TAG when TAG is an external member. +TAG is an external member if it is defined at a toplevel and +has some sort of label defining a parent. The parent return will +be a string. + +The default behavior, if not overridden with +`tag-member-parent' gets the 'parent extra +specifier of TAG. + +If this function is overridden, use +`semantic-tag-external-member-parent-default' to also +include the default behavior, and merely extend your own." + ) + +(defun semantic-tag-external-member-parent-default (tag) + "Return the name of TAGs parent only if TAG is not defined in it's parent." + ;; Use only the extra spec because a type has a parent which + ;; means something completely different. + (let ((tp (semantic-tag-get-attribute tag :parent))) + (when (stringp tp) + tp) + )) + +(semantic-alias-obsolete 'semantic-nonterminal-external-member-parent + 'semantic-tag-external-member-parent) + +(define-overloadable-function semantic-tag-external-member-p (parent tag) + "Return non-nil if PARENT is the parent of TAG. +TAG is an external member of PARENT when it is somehow tagged +as having PARENT as it's parent. +PARENT and TAG must both be semantic tags. + +The default behavior, if not overridden with +`tag-external-member-p' is to match :parent attribute in +the name of TAG. + +If this function is overridden, use +`semantic-tag-external-member-children-p-default' to also +include the default behavior, and merely extend your own." + ) + +(defun semantic-tag-external-member-p-default (parent tag) + "Return non-nil if PARENT is the parent of TAG." + ;; Use only the extra spec because a type has a parent which + ;; means something completely different. + (let ((tp (semantic-tag-external-member-parent tag))) + (and (stringp tp) + (string= (semantic-tag-name parent) tp)) + )) + +(semantic-alias-obsolete 'semantic-nonterminal-external-member-p + 'semantic-tag-external-member-p) + +(define-overloadable-function semantic-tag-external-member-children (tag &optional usedb) + "Return the list of children which are not *in* TAG. +If optional argument USEDB is non-nil, then also search files in +the Semantic Database. If USEDB is a list of databases, search those +databases. + +Children in this case are functions or types which are members of +TAG, such as the parts of a type, but which are not defined inside +the class. C++ and CLOS both permit methods of a class to be defined +outside the bounds of the class' definition. + +The default behavior, if not overridden with +`tag-external-member-children' is to search using +`semantic-tag-external-member-p' in all top level definitions +with a parent of TAG. + +If this function is overridden, use +`semantic-tag-external-member-children-default' to also +include the default behavior, and merely extend your own." + ) + +(defun semantic-tag-external-member-children-default (tag &optional usedb) + "Return list of external children for TAG. +Optional argument USEDB specifies if the semantic database is used. +See `semantic-tag-external-member-children' for details." + (if (and usedb + (fboundp 'semanticdb-minor-mode-p) + (semanticdb-minor-mode-p)) + (let ((m (semanticdb-find-tags-external-children-of-type + (semantic-tag-name tag)))) + (if m (apply #'append (mapcar #'cdr m)))) + (semantic--find-tags-by-function + `(lambda (tok) + ;; This bit of annoying backquote forces the contents of + ;; tag into the generated lambda. + (semantic-tag-external-member-p ',tag tok)) + (current-buffer)) + )) + +(define-overloadable-function semantic-tag-external-class (tag) + "Return a list of real tags that faux TAG might represent. + +In some languages, a method can be defined on an object which is +not in the same file. In this case, +`semantic-adopt-external-members' will create a faux-tag. If it +is necessary to get the tag from which for faux TAG was most +likely derived, then this function is needed." + (unless (semantic-tag-faux-p tag) + (signal 'wrong-type-argument (list tag 'semantic-tag-faux-p))) + (:override) + ) + +(defun semantic-tag-external-class-default (tag) + "Return a list of real tags that faux TAG might represent. +See `semantic-tag-external-class' for details." + (if (and (fboundp 'semanticdb-minor-mode-p) + (semanticdb-minor-mode-p)) + (let* ((semanticdb-search-system-databases nil) + (m (semanticdb-find-tags-by-class + (semantic-tag-class tag) + (semanticdb-find-tags-by-name (semantic-tag-name tag))))) + (semanticdb-strip-find-results m 'name)) + ;; Presumably, if the tag is faux, it is not local. + nil + )) + +(semantic-alias-obsolete 'semantic-nonterminal-external-member-children + 'semantic-tag-external-member-children) + +(provide 'semantic/sort) + +;;; semantic-sort.el ends here