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

   1 ;;; semantic-sort.el --- Utilities for sorting and re-arranging tag tables.
   2
   3 ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007 Eric M. Ludlam
   4
   5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   6 ;; Keywords: syntax
   7 ;; X-RCS: $Id: semantic-sort.el,v 1.1 2007-11-26 15:10:42 michaels Exp $
   8
   9 ;; This file is not part of GNU Emacs.
  10
  11 ;; Semantic is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This software is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27 ;;
  28 ;; Tag tables originate in the order they appear in a buffer, or source file.
  29 ;; It is often useful to re-arrange them is some predictable way for browsing
  30 ;; purposes.  Re-organization may be alphabetical, or even a complete
  31 ;; reorganization of parents and children.
  32 ;;
  33 ;; Originally written in semantic-util.el
  34 ;;
  35
  36 (require 'assoc)
  37 (require 'semantic)
  38 (require 'semanticdb)
  39 (eval-when-compile
  40   (require 'semantic-find)
  41   (require 'semanticdb-find))
  42
  43 ;;; Alphanumeric sorting
  44 ;;
  45 ;; Takes a list of tags, and sorts them in a case-insensitive way
  46 ;; at a single level.
  47
  48 ;;; Code:
  49 (defun semantic-string-lessp-ci (s1 s2)
  50   "Case insensitive version of `string-lessp'.
  51 Argument S1 and S2 are the strings to compare."
  52   ;; Use downcase instead of upcase because an average name
  53   ;; has more lower case characters.
  54   (if (fboundp 'compare-strings)
  55       (eq (compare-strings s1 0 nil s2 0 nil t) -1)
  56     (string-lessp (downcase s1) (downcase s2))))
  57
  58 (defun semantic-sort-tag-type (tag)
  59   "Return a type string for TAG guaranteed to be a string."
  60   (let ((ty (semantic-tag-type tag)))
  61     (cond ((stringp ty)
  62            ty)
  63           ((listp ty)
  64            (or (car ty) ""))
  65           (t ""))))
  66
  67 ;;;###autoload
  68 (defun semantic-sort-tags-by-name-increasing (tags)
  69   "Sort TAGS by name in increasing order with side effects.
  70 Return the sorted list."
  71   (sort tags (lambda (a b)
  72                (string-lessp (semantic-tag-name a)
  73                              (semantic-tag-name b)))))
  74
  75 ;;;###autoload
  76 (defun semantic-sort-tags-by-name-decreasing (tags)
  77   "Sort TAGS by name in decreasing order with side effects.
  78 Return the sorted list."
  79   (sort tags (lambda (a b)
  80                (string-lessp (semantic-tag-name b)
  81                              (semantic-tag-name a)))))
  82
  83 ;;;###autoload
  84 (defun semantic-sort-tags-by-type-increasing (tags)
  85   "Sort TAGS by type in increasing order with side effects.
  86 Return the sorted list."
  87   (sort tags (lambda (a b)
  88                (string-lessp (semantic-sort-tag-type a)
  89                              (semantic-sort-tag-type b)))))
  90
  91 ;;;###autoload
  92 (defun semantic-sort-tags-by-type-decreasing (tags)
  93   "Sort TAGS by type in decreasing order with side effects.
  94 Return the sorted list."
  95   (sort tags (lambda (a b)
  96                (string-lessp (semantic-sort-tag-type b)
  97                              (semantic-sort-tag-type a)))))
  98
  99 ;;;###autoload
 100 (defun semantic-sort-tags-by-name-increasing-ci (tags)
 101   "Sort TAGS by name in increasing order with side effects.
 102 Return the sorted list."
 103   (sort tags (lambda (a b)
 104                (semantic-string-lessp-ci (semantic-tag-name a)
 105                                          (semantic-tag-name b)))))
 106
 107 ;;;###autoload
 108 (defun semantic-sort-tags-by-name-decreasing-ci (tags)
 109   "Sort TAGS by name in decreasing order with side effects.
 110 Return the sorted list."
 111   (sort tags (lambda (a b)
 112                (semantic-string-lessp-ci (semantic-tag-name b)
 113                                          (semantic-tag-name a)))))
 114
 115 ;;;###autoload
 116 (defun semantic-sort-tags-by-type-increasing-ci (tags)
 117   "Sort TAGS by type in increasing order with side effects.
 118 Return the sorted list."
 119   (sort tags (lambda (a b)
 120                (semantic-string-lessp-ci (semantic-sort-tag-type a)
 121                                          (semantic-sort-tag-type b)))))
 122
 123 ;;;###autoload
 124 (defun semantic-sort-tags-by-type-decreasing-ci (tags)
 125   "Sort TAGS by type in decreasing order with side effects.
 126 Return the sorted list."
 127   (sort tags (lambda (a b)
 128                (semantic-string-lessp-ci (semantic-sort-tag-type b)
 129                                          (semantic-sort-tag-type a)))))
 130
 131 (semantic-alias-obsolete 'semantic-sort-tokens-by-name-increasing
 132                          'semantic-sort-tags-by-name-increasing)
 133 (semantic-alias-obsolete 'semantic-sort-tokens-by-name-decreasing
 134                          'semantic-sort-tags-by-name-decreasing)
 135 (semantic-alias-obsolete 'semantic-sort-tokens-by-type-increasing
 136                          'semantic-sort-tags-by-type-increasing)
 137 (semantic-alias-obsolete 'semantic-sort-tokens-by-type-decreasing
 138                          'semantic-sort-tags-by-type-decreasing)
 139 (semantic-alias-obsolete 'semantic-sort-tokens-by-name-increasing-ci
 140                          'semantic-sort-tags-by-name-increasing-ci)
 141 (semantic-alias-obsolete 'semantic-sort-tokens-by-name-decreasing-ci
 142                          'semantic-sort-tags-by-name-decreasing-ci)
 143 (semantic-alias-obsolete 'semantic-sort-tokens-by-type-increasing-ci
 144                          'semantic-sort-tags-by-type-increasing-ci)
 145 (semantic-alias-obsolete 'semantic-sort-tokens-by-type-decreasing-ci
 146                          'semantic-sort-tags-by-type-decreasing-ci)
 147
 148 \f
 149 ;;; Unique
 150 ;;
 151 ;; Scan a list of tags, removing duplicates.
 152 ;; This must first sort the tags by name alphabetically ascending.
 153 ;;
 154 ;; Useful for completion lists, or other situations where the
 155 ;; other data isn't as useful.
 156
 157 ;;;###autoload
 158 (defun semantic-unique-tag-table-by-name (tags)
 159   "Scan a list of TAGS, removing duplicate names.
 160 This must first sort the tags by name alphabetically ascending."
 161   (let ((copy (copy-sequence tags))
 162         (sorted (semantic-sort-tags-by-name-increasing
 163                  (copy-sequence tags)))
 164         (uniq nil))
 165     (while sorted
 166       (if (or (not uniq)
 167               (not (string= (semantic-tag-name (car sorted))
 168                             (semantic-tag-name (car uniq)))))
 169           (setq uniq (cons (car sorted) uniq)))
 170       (setq sorted (cdr sorted))
 171       )
 172     (nreverse uniq)))
 173
 174 ;;;###autoload
 175 (defun semantic-unique-tag-table (tags)
 176   "Scan a list of TAGS, removing duplicates.
 177 This must first sort the tags by position ascending.
 178 TAGS are removed only if they are equivalent, as can happen when
 179 multiple tag sources are scanned."
 180   (let ((copy (copy-sequence tags))
 181         (sorted (sort (copy-sequence tags)
 182                       (lambda (a b)
 183                         (cond ((not (semantic-tag-with-position-p a))
 184                                t)
 185                               ((not (semantic-tag-with-position-p b))
 186                                nil)
 187                               (t
 188                                (< (semantic-tag-start a)
 189                                   (semantic-tag-start b)))))))
 190         (uniq nil))
 191     (while sorted
 192       (if (or (not uniq)
 193               (not (semantic-equivalent-tag-p (car sorted) (car uniq))))
 194           (setq uniq (cons (car sorted) uniq)))
 195       (setq sorted (cdr sorted))
 196       )
 197     (nreverse uniq)))
 198
 199 \f
 200 ;;; Tag Table Flattening
 201 ;;
 202 ;; In the 1.4 search API, there was a parameter "search-parts" which
 203 ;; was used to find tags inside other tags.  This was used
 204 ;; infrequently, mostly for completion/jump routines.  These types
 205 ;; of commands would be better off with a flattened list, where all
 206 ;; tags appear at the top level.
 207
 208 ;;;###autoload
 209 (defun semantic-flatten-tags-table (&optional table)
 210   "Flatten the tags table TABLE.
 211 All tags in TABLE, and all components of top level tags
 212 in TABLE will appear at the top level of list.
 213 Tags promoted to the top of the list will still appear
 214 unmodified as components of their parent tags."
 215   (let* ((table (semantic-something-to-tag-table table))
 216          ;; Initialize the starting list with our table.
 217          (lists (list table)))
 218     (mapc (lambda (tag)
 219             (let ((components (semantic-tag-components tag)))
 220               (if (and components
 221                        ;; unpositined tags can be hazardous to
 222                        ;; completion.  Do we need any type of tag
 223                        ;; here?  - EL
 224                        (semantic-tag-with-position-p (car components)))
 225                   (setq lists (cons
 226                                (semantic-flatten-tags-table components)
 227                                lists)))))
 228           table)
 229     (apply 'append (nreverse lists))
 230     ))
 231
 232 \f
 233 ;;; Buckets:
 234 ;;
 235 ;; A list of tags can be grouped into buckets based on the tag class.
 236 ;; Bucketize means to take a list of tags at a given level in a tag
 237 ;; table, and reorganize them into buckets based on class.
 238 ;;
 239 (defvar semantic-bucketize-tag-class
 240   ;; Must use lambda because `semantic-tag-class' is a macro.
 241   (lambda (tok) (semantic-tag-class tok))
 242   "Function used to get a symbol describing the class of a tag.
 243 This function must take one argument of a semantic tag.
 244 It should return a symbol found in `semantic-symbol->name-assoc-list'
 245 which `semantic-bucketize' uses to bin up tokens.
 246 To create new bins for an application augment
 247 `semantic-symbol->name-assoc-list', and
 248 `semantic-symbol->name-assoc-list-for-type-parts' in addition
 249 to setting this variable (locally in your function).")
 250
 251 ;;;###autoload
 252 (defun semantic-bucketize (tags &optional parent filter)
 253   "Sort TAGS into a group of buckets based on tag class.
 254 Unknown classes are placed in a Misc bucket.
 255 Type bucket names are defined by either `semantic-symbol->name-assoc-list'.
 256 If PARENT is specified, then TAGS belong to this PARENT in some way.
 257 This will use `semantic-symbol->name-assoc-list-for-type-parts' to
 258 generate bucket names.
 259 Optional argument FILTER is a filter function to be applied to each bucket.
 260 The filter function will take one argument, which is a list of tokens, and
 261 may re-organize the list with side-effects."
 262   (let* ((name-list (if parent
 263                         semantic-symbol->name-assoc-list-for-type-parts
 264                       semantic-symbol->name-assoc-list))
 265          (sn name-list)
 266          (bins (make-vector (1+ (length sn)) nil))
 267          ask tagtype
 268          (nsn nil)
 269          (num 1)
 270          (out nil))
 271     ;; Build up the bucket vector
 272     (while sn
 273       (setq nsn (cons (cons (car (car sn)) num) nsn)
 274             sn (cdr sn)
 275             num (1+ num)))
 276     ;; Place into buckets
 277     (while tags
 278       (setq tagtype (funcall semantic-bucketize-tag-class (car tags))
 279             ask (assq tagtype nsn)
 280             num (or (cdr ask) 0))
 281       (aset bins num (cons (car tags) (aref bins num)))
 282       (setq tags (cdr tags)))
 283     ;; Remove from buckets into a list.
 284     (setq num 1)
 285     (while (< num (length bins))
 286       (when (aref bins num)
 287         (setq out
 288               (cons (cons
 289                      (cdr (nth (1- num) name-list))
 290                      ;; Filtering, First hacked by David Ponce david@dponce.com
 291                      (funcall (or filter 'nreverse) (aref bins num)))
 292                     out)))
 293       (setq num (1+ num)))
 294     (if (aref bins 0)
 295         (setq out (cons (cons "Misc"
 296                               (funcall (or filter 'nreverse) (aref bins 0)))
 297                         out)))
 298     (nreverse out)))
 299 \f
 300 ;;; Adoption
 301 ;;
 302 ;; Some languages allow children of a type to be defined outside
 303 ;; the syntactic scope of that class.  These routines will find those
 304 ;; external members, and bring them together in a cloned copy of the
 305 ;; class tag.
 306 ;;
 307 ;;;###autoload
 308 (defvar semantic-orphaned-member-metaparent-type "class"
 309   "In `semantic-adopt-external-members', the type of 'type for metaparents.
 310 A metaparent is a made-up type semantic token used to hold the child list
 311 of orphaned members of a named type.")
 312 (make-variable-buffer-local 'semantic-orphaned-member-metaparent-type)
 313
 314 (defvar semantic-mark-external-member-function nil
 315   "Function called when an externally defined orphan is found.
 316 By default, the token is always marked with the `adopted' property.
 317 This function should be locally bound by a program that needs
 318 to add additional behaviors into the token list.
 319 This function is called with two arguments.  The first is TOKEN which is
 320 a shallow copy of the token to be modified.  The second is the PARENT
 321 which is adopting TOKEN.  This function should return TOKEN (or a copy of it)
 322 which is then integrated into the revised token list.")
 323
 324 ;;;###autoload
 325 (defun semantic-adopt-external-members (tags)
 326   "Rebuild TAGS so that externally defined members are regrouped.
 327 Some languages such as C++ and CLOS permit the declaration of member
 328 functions outside the definition of the class.  It is easier to study
 329 the structure of a program when such methods are grouped together
 330 more logically.
 331
 332 This function uses `semantic-tag-external-member-p' to
 333 determine when a potential child is an externally defined member.
 334
 335 Note: Applications which use this function must account for token
 336 types which do not have a position, but have children which *do*
 337 have positions.
 338
 339 Applications should use `semantic-mark-external-member-function'
 340 to modify all tags which are found as externally defined to some
 341 type.  For example, changing the token type for generating extra
 342 buckets with the bucket function."
 343   (let ((parent-buckets nil)
 344         (decent-list nil)
 345         (out nil)
 346         (tmp nil)
 347         )
 348     ;; Rebuild the output list, stripping out all parented
 349     ;; external entries
 350     (while tags
 351       (cond
 352        ((setq tmp (semantic-tag-external-member-parent (car tags)))
 353         (let ((tagcopy (semantic-tag-clone (car tags)))
 354               (a (assoc tmp parent-buckets)))
 355           (semantic--tag-put-property-no-side-effect tagcopy 'adopted t)
 356           (if a
 357               ;; If this parent is already in the list, append.
 358               (setcdr (nthcdr (1- (length a)) a) (list tagcopy))
 359             ;; If not, prepend this new parent bucket into our list
 360             (setq parent-buckets
 361                   (cons (cons tmp (list tagcopy)) parent-buckets)))
 362           ))
 363        ((eq (semantic-tag-class (car tags)) 'type)
 364         ;; Types need to be rebuilt from scratch so we can add in new
 365         ;; children to the child list.  Only the top-level cons
 366         ;; cells need to be duplicated so we can hack out the
 367         ;; child list later.
 368         (setq out (cons (semantic-tag-clone (car tags)) out))
 369         (setq decent-list (cons (car out) decent-list))
 370         )
 371        (t
 372         ;; Otherwise, append this tag to our new output list.
 373         (setq out (cons (car tags) out)))
 374        )
 375       (setq tags (cdr tags)))
 376     ;; Rescan out, by descending into all types and finding parents
 377     ;; for all entries moved into the parent-buckets.
 378     (while decent-list
 379       (let* ((bucket (assoc (semantic-tag-name (car decent-list))
 380                             parent-buckets))
 381              (bucketkids (cdr bucket)))
 382         (when bucket
 383           ;; Run our secondary marking function on the children
 384           (if semantic-mark-external-member-function
 385               (setq bucketkids
 386                     (mapcar (lambda (tok)
 387                               (funcall semantic-mark-external-member-function
 388                                        tok (car decent-list)))
 389                             bucketkids)))
 390           ;; We have some extra kids.  Merge.
 391           (semantic-tag-put-attribute
 392            (car decent-list) :members
 393            (append (semantic-tag-type-members (car decent-list))
 394                    bucketkids))
 395           ;; Nuke the bucket label so it is not found again.
 396           (setcar bucket nil))
 397         (setq decent-list
 398               (append (cdr decent-list)
 399                       ;; get embedded types to scan and make copies
 400                       ;; of them.
 401                       (mapcar
 402                        (lambda (tok) (semantic-tag-clone tok))
 403                        (semantic-find-tags-by-class 'type
 404                         (semantic-tag-type-members (car decent-list)))))
 405               )))
 406     ;; Scan over all remaining lost external methods, and tack them
 407     ;; onto the end.
 408     (while parent-buckets
 409       (if (car (car parent-buckets))
 410           (let* ((tmp (car parent-buckets))
 411                  (fauxtag (semantic-tag-new-type
 412                            (car tmp)
 413                            semantic-orphaned-member-metaparent-type
 414                            nil ;; Part list
 415                            nil ;; parents (unknown)
 416                            ))
 417                  (bucketkids (cdr tmp)))
 418             (semantic-tag-set-faux fauxtag) ;; properties
 419             (if semantic-mark-external-member-function
 420                 (setq bucketkids
 421                       (mapcar (lambda (tok)
 422                                 (funcall semantic-mark-external-member-function
 423                                          tok fauxtag))
 424                               bucketkids)))
 425             (semantic-tag-put-attribute fauxtag :members bucketkids)
 426             ;; We have a bunch of methods with no parent in this file.
 427             ;; Create a meta-type to hold it.
 428             (setq out (cons fauxtag out))
 429             ))
 430       (setq parent-buckets (cdr parent-buckets)))
 431     ;; Return the new list.
 432     (nreverse out)))
 433
 434 \f
 435 ;;; External children
 436 ;;
 437 ;; In order to adopt external children, we need a few overload methods
 438 ;; to enable the feature.
 439 ;;
 440 ;;;###autoload
 441 (define-overload semantic-tag-external-member-parent (tag)
 442   "Return a parent for TAG when TAG is an external member.
 443 TAG is an external member if it is defined at a toplevel and
 444 has some sort of label defining a parent.  The parent return will
 445 be a string.
 446
 447 The default behavior, if not overridden with
 448 `tag-member-parent' gets the 'parent extra
 449 specifier of TAG.
 450
 451 If this function is overridden, use
 452 `semantic-tag-external-member-parent-default' to also
 453 include the default behavior, and merely extend your own."
 454   )
 455
 456 (defun semantic-tag-external-member-parent-default (tag)
 457   "Return the name of TAGs parent only if TAG is not defined in it's parent."
 458   ;; Use only the extra spec because a type has a parent which
 459   ;; means something completely different.
 460   (let ((tp (semantic-tag-get-attribute tag :parent)))
 461     (when (stringp tp)
 462       tp)
 463     ))
 464
 465 (semantic-alias-obsolete 'semantic-nonterminal-external-member-parent
 466                          'semantic-tag-external-member-parent)
 467
 468 ;;;###autoload
 469 (define-overload semantic-tag-external-member-p (parent tag)
 470   "Return non-nil if PARENT is the parent of TAG.
 471 TAG is an external member of PARENT when it is somehow tagged
 472 as having PARENT as it's parent.
 473 PARENT and TAG must both be semantic tags.
 474
 475 The default behavior, if not overridden with
 476 `tag-external-member-p' is to match :parent attribute in
 477 the name of TAG.
 478
 479 If this function is overridden, use
 480 `semantic-tag-external-member-children-p-default' to also
 481 include the default behavior, and merely extend your own."
 482   )
 483
 484 (defun semantic-tag-external-member-p-default (parent tag)
 485   "Return non-nil if PARENT is the parent of TAG."
 486   ;; Use only the extra spec because a type has a parent which
 487   ;; means something completely different.
 488   (let ((tp (semantic-tag-external-member-parent tag)))
 489     (and (stringp tp)
 490          (string= (semantic-tag-name parent) tp))
 491     ))
 492
 493 (semantic-alias-obsolete 'semantic-nonterminal-external-member-p
 494                          'semantic-tag-external-member-p)
 495
 496 ;;;###autoload
 497 (define-overload semantic-tag-external-member-children (tag &optional usedb)
 498   "Return the list of children which are not *in* TAG.
 499 If optional argument USEDB is non-nil, then also search files in
 500 the Semantic Database.  If USEDB is a list of databases, search those
 501 databases.
 502
 503 Children in this case are functions or types which are members of
 504 TAG, such as the parts of a type, but which are not defined inside
 505 the class.  C++ and CLOS both permit methods of a class to be defined
 506 outside the bounds of the class' definition.
 507
 508 The default behavior, if not overridden with
 509 `tag-external-member-children' is to search using
 510 `semantic-tag-external-member-p' in all top level definitions
 511 with a parent of TAG.
 512
 513 If this function is overridden, use
 514 `semantic-tag-external-member-children-default' to also
 515 include the default behavior, and merely extend your own."
 516   )
 517
 518 (defun semantic-tag-external-member-children-default (tag &optional usedb)
 519   "Return list of external children for TAG.
 520 Optional argument USEDB specifies if the semantic database is used.
 521 See `semantic-tag-external-member-children' for details."
 522   (if (and usedb
 523            (fboundp 'semanticdb-minor-mode-p)
 524            (semanticdb-minor-mode-p))
 525       (let ((m (semanticdb-find-tags-external-children-of-type
 526                 (semantic-tag-name tag))))
 527         (if m (apply #'append (mapcar #'cdr m))))
 528     (semantic--find-tags-by-function
 529      `(lambda (tok)
 530         ;; This bit of annoying backquote forces the contents of
 531         ;; tag into the generated lambda.
 532        (semantic-tag-external-member-p ',tag tok))
 533      (current-buffer))
 534     ))
 535
 536 ;;;###autoload
 537 (define-overload semantic-tag-external-class (tag)
 538   "Return a list of real tags that faux TAG might represent.
 539
 540 In some languages, a method can be defined on an object which is
 541 not in the same file.  In this case,
 542 `semantic-adopt-external-members' will create a faux-tag.  If it
 543 is necessary to get the tag from which for faux TAG was most
 544 likely derived, then this function is needed."
 545   (unless (semantic-tag-faux-p tag)
 546     (signal 'wrong-type-argument (list tag 'semantic-tag-faux-p)))
 547   (:override)
 548   )
 549
 550 (defun semantic-tag-external-class-default (tag)
 551   "Return a list of real tags that faux TAG might represent.
 552 See `semantic-tag-external-class' for details."
 553   (if (and (fboundp 'semanticdb-minor-mode-p)
 554            (semanticdb-minor-mode-p))
 555       (let* ((semanticdb-search-system-databases nil)
 556              (m (semanticdb-find-tags-by-class
 557                  (semantic-tag-class tag)
 558                  (semanticdb-find-tags-by-name (semantic-tag-name tag)))))
 559         (semanticdb-strip-find-results m t))
 560     ;; Presumably, if the tag is faux, it is not local.
 561     nil
 562     ))
 563
 564 (semantic-alias-obsolete 'semantic-nonterminal-external-member-children
 565                          'semantic-tag-external-member-children)
 566
 567 (provide 'semantic-sort)
 568
 569 ;;; semantic-sort.el ends here