code.delx.au - gnu-emacs/blob - lisp/cedet/semantic/sort.el

   1 ;;; sort.el --- Utilities for sorting and re-arranging tag tables.
   2
   3 ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
   4 ;;; 2008, 2009, 2010, 2011, 2012 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 ;; 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.
  30 ;;
  31 ;; Originally written in semantic-util.el
  32 ;;
  33
  34 (require 'semantic)
  35 (eval-when-compile
  36   (require 'semantic/find))
  37
  38 (declare-function semanticdb-find-tags-external-children-of-type
  39                   "semantic/db-find")
  40
  41 ;;; Alphanumeric sorting
  42 ;;
  43 ;; Takes a list of tags, and sorts them in a case-insensitive way
  44 ;; at a single level.
  45
  46 ;;; Code:
  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))))
  55
  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)))
  59     (cond ((stringp ty)
  60            ty)
  61           ((listp ty)
  62            (or (car ty) ""))
  63           (t ""))))
  64
  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
  68 each tag."
  69   (let ((na (semantic-tag-name A))
  70         (nb (semantic-tag-name B))
  71         )
  72     (if (string-lessp na nb)
  73         t ; a sure thing.
  74       (if (string= 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)
  79                              ta)
  80                             ((semantic-tag-p ta)
  81                              (semantic-tag-name ta))
  82                             (t nil)))
  83                  (tbs (cond ((stringp tb)
  84                              tb)
  85                             ((semantic-tag-p tb)
  86                              (semantic-tag-name tb))
  87                             (t nil))))
  88             (if (and (stringp tas) (stringp tbs))
  89                 (string< tas tbs)
  90               ;; This is if A == B, and no types in A or B
  91               nil))
  92         ;; This nil is if A > B, but not =
  93         nil))))
  94
  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)))))
 101
 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)))))
 108
 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)))))
 115
 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)))))
 122
 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)))))
 129
 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)))))
 136
 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)))))
 143
 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)))))
 150
 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))))
 155
 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))))
 160 \f
 161 ;;; Unique
 162 ;;
 163 ;; Scan a list of tags, removing duplicates.
 164 ;; This must first sort the tags by name alphabetically ascending.
 165 ;;
 166 ;; Useful for completion lists, or other situations where the
 167 ;; other data isn't as useful.
 168
 169 (defun semantic-unique-tag-table-by-name (tags)
 170   "Scan a list of TAGS, removing duplicate names.
 171 This must first sort the tags by name alphabetically ascending.
 172 For more complex uniqueness testing used by the semanticdb
 173 typecaching system, see `semanticdb-typecache-merge-streams'."
 174   (let ((sorted (semantic-sort-tags-by-name-increasing
 175                  (copy-sequence tags)))
 176         (uniq nil))
 177     (while sorted
 178       (if (or (not uniq)
 179               (not (string= (semantic-tag-name (car sorted))
 180                             (semantic-tag-name (car uniq)))))
 181           (setq uniq (cons (car sorted) uniq)))
 182       (setq sorted (cdr sorted))
 183       )
 184     (nreverse uniq)))
 185
 186 (defun semantic-unique-tag-table (tags)
 187   "Scan a list of TAGS, removing duplicates.
 188 This must first sort the tags by position ascending.
 189 TAGS are removed only if they are equivalent, as can happen when
 190 multiple tag sources are scanned.
 191 For more complex uniqueness testing used by the semanticdb
 192 typecaching system, see `semanticdb-typecache-merge-streams'."
 193   (let ((sorted (sort (copy-sequence tags)
 194                       (lambda (a b)
 195                         (cond ((not (semantic-tag-with-position-p a))
 196                                t)
 197                               ((not (semantic-tag-with-position-p b))
 198                                nil)
 199                               (t
 200                                (< (semantic-tag-start a)
 201                                   (semantic-tag-start b)))))))
 202         (uniq nil))
 203     (while sorted
 204       (if (or (not uniq)
 205               (not (semantic-equivalent-tag-p (car sorted) (car uniq))))
 206           (setq uniq (cons (car sorted) uniq)))
 207       (setq sorted (cdr sorted))
 208       )
 209     (nreverse uniq)))
 210
 211 \f
 212 ;;; Tag Table Flattening
 213 ;;
 214 ;; In the 1.4 search API, there was a parameter "search-parts" which
 215 ;; was used to find tags inside other tags.  This was used
 216 ;; infrequently, mostly for completion/jump routines.  These types
 217 ;; of commands would be better off with a flattened list, where all
 218 ;; tags appear at the top level.
 219
 220 ;;;###autoload
 221 (defun semantic-flatten-tags-table (&optional table)
 222   "Flatten the tags table TABLE.
 223 All tags in TABLE, and all components of top level tags
 224 in TABLE will appear at the top level of list.
 225 Tags promoted to the top of the list will still appear
 226 unmodified as components of their parent tags."
 227   (let* ((table (semantic-something-to-tag-table table))
 228          ;; Initialize the starting list with our table.
 229          (lists (list table)))
 230     (mapc (lambda (tag)
 231             (let ((components (semantic-tag-components tag)))
 232               (if (and components
 233                        ;; unpositined tags can be hazardous to
 234                        ;; completion.  Do we need any type of tag
 235                        ;; here?  - EL
 236                        (semantic-tag-with-position-p (car components)))
 237                   (setq lists (cons
 238                                (semantic-flatten-tags-table components)
 239                                lists)))))
 240           table)
 241     (apply 'append (nreverse lists))
 242     ))
 243
 244 \f
 245 ;;; Buckets:
 246 ;;
 247 ;; A list of tags can be grouped into buckets based on the tag class.
 248 ;; Bucketize means to take a list of tags at a given level in a tag
 249 ;; table, and reorganize them into buckets based on class.
 250 ;;
 251 (defvar semantic-bucketize-tag-class
 252   ;; Must use lambda because `semantic-tag-class' is a macro.
 253   (lambda (tok) (semantic-tag-class tok))
 254   "Function used to get a symbol describing the class of a tag.
 255 This function must take one argument of a semantic tag.
 256 It should return a symbol found in `semantic-symbol->name-assoc-list'
 257 which `semantic-bucketize' uses to bin up tokens.
 258 To create new bins for an application augment
 259 `semantic-symbol->name-assoc-list', and
 260 `semantic-symbol->name-assoc-list-for-type-parts' in addition
 261 to setting this variable (locally in your function).")
 262
 263 (defun semantic-bucketize (tags &optional parent filter)
 264   "Sort TAGS into a group of buckets based on tag class.
 265 Unknown classes are placed in a Misc bucket.
 266 Type bucket names are defined by either `semantic-symbol->name-assoc-list'.
 267 If PARENT is specified, then TAGS belong to this PARENT in some way.
 268 This will use `semantic-symbol->name-assoc-list-for-type-parts' to
 269 generate bucket names.
 270 Optional argument FILTER is a filter function to be applied to each bucket.
 271 The filter function will take one argument, which is a list of tokens, and
 272 may re-organize the list with side-effects."
 273   (let* ((name-list (if parent
 274                         semantic-symbol->name-assoc-list-for-type-parts
 275                       semantic-symbol->name-assoc-list))
 276          (sn name-list)
 277          (bins (make-vector (1+ (length sn)) nil))
 278          ask tagtype
 279          (nsn nil)
 280          (num 1)
 281          (out nil))
 282     ;; Build up the bucket vector
 283     (while sn
 284       (setq nsn (cons (cons (car (car sn)) num) nsn)
 285             sn (cdr sn)
 286             num (1+ num)))
 287     ;; Place into buckets
 288     (while tags
 289       (setq tagtype (funcall semantic-bucketize-tag-class (car tags))
 290             ask (assq tagtype nsn)
 291             num (or (cdr ask) 0))
 292       (aset bins num (cons (car tags) (aref bins num)))
 293       (setq tags (cdr tags)))
 294     ;; Remove from buckets into a list.
 295     (setq num 1)
 296     (while (< num (length bins))
 297       (when (aref bins num)
 298         (setq out
 299               (cons (cons
 300                      (cdr (nth (1- num) name-list))
 301                      ;; Filtering, First hacked by David Ponce david@dponce.com
 302                      (funcall (or filter 'nreverse) (aref bins num)))
 303                     out)))
 304       (setq num (1+ num)))
 305     (if (aref bins 0)
 306         (setq out (cons (cons "Misc"
 307                               (funcall (or filter 'nreverse) (aref bins 0)))
 308                         out)))
 309     (nreverse out)))
 310 \f
 311 ;;; Adoption
 312 ;;
 313 ;; Some languages allow children of a type to be defined outside
 314 ;; the syntactic scope of that class.  These routines will find those
 315 ;; external members, and bring them together in a cloned copy of the
 316 ;; class tag.
 317 ;;
 318 (defvar semantic-orphaned-member-metaparent-type "class"
 319   "In `semantic-adopt-external-members', the type of 'type for metaparents.
 320 A metaparent is a made-up type semantic token used to hold the child list
 321 of orphaned members of a named type.")
 322 (make-variable-buffer-local 'semantic-orphaned-member-metaparent-type)
 323
 324 (defvar semantic-mark-external-member-function nil
 325   "Function called when an externally defined orphan is found.
 326 By default, the token is always marked with the `adopted' property.
 327 This function should be locally bound by a program that needs
 328 to add additional behaviors into the token list.
 329 This function is called with two arguments.  The first is TOKEN which is
 330 a shallow copy of the token to be modified.  The second is the PARENT
 331 which is adopting TOKEN.  This function should return TOKEN (or a copy of it)
 332 which is then integrated into the revised token list.")
 333
 334 (defun semantic-adopt-external-members (tags)
 335   "Rebuild TAGS so that externally defined members are regrouped.
 336 Some languages such as C++ and CLOS permit the declaration of member
 337 functions outside the definition of the class.  It is easier to study
 338 the structure of a program when such methods are grouped together
 339 more logically.
 340
 341 This function uses `semantic-tag-external-member-p' to
 342 determine when a potential child is an externally defined member.
 343
 344 Note: Applications which use this function must account for token
 345 types which do not have a position, but have children which *do*
 346 have positions.
 347
 348 Applications should use `semantic-mark-external-member-function'
 349 to modify all tags which are found as externally defined to some
 350 type.  For example, changing the token type for generating extra
 351 buckets with the bucket function."
 352   (let ((parent-buckets nil)
 353         (decent-list nil)
 354         (out nil)
 355         (tmp nil)
 356         )
 357     ;; Rebuild the output list, stripping out all parented
 358     ;; external entries
 359     (while tags
 360       (cond
 361        ((setq tmp (semantic-tag-external-member-parent (car tags)))
 362         (let ((tagcopy (semantic-tag-clone (car tags)))
 363               (a (assoc tmp parent-buckets)))
 364           (semantic--tag-put-property-no-side-effect tagcopy 'adopted t)
 365           (if a
 366               ;; If this parent is already in the list, append.
 367               (setcdr (nthcdr (1- (length a)) a) (list tagcopy))
 368             ;; If not, prepend this new parent bucket into our list
 369             (setq parent-buckets
 370                   (cons (cons tmp (list tagcopy)) parent-buckets)))
 371           ))
 372        ((eq (semantic-tag-class (car tags)) 'type)
 373         ;; Types need to be rebuilt from scratch so we can add in new
 374         ;; children to the child list.  Only the top-level cons
 375         ;; cells need to be duplicated so we can hack out the
 376         ;; child list later.
 377         (setq out (cons (semantic-tag-clone (car tags)) out))
 378         (setq decent-list (cons (car out) decent-list))
 379         )
 380        (t
 381         ;; Otherwise, append this tag to our new output list.
 382         (setq out (cons (car tags) out)))
 383        )
 384       (setq tags (cdr tags)))
 385     ;; Rescan out, by descending into all types and finding parents
 386     ;; for all entries moved into the parent-buckets.
 387     (while decent-list
 388       (let* ((bucket (assoc (semantic-tag-name (car decent-list))
 389                             parent-buckets))
 390              (bucketkids (cdr bucket)))
 391         (when bucket
 392           ;; Run our secondary marking function on the children
 393           (if semantic-mark-external-member-function
 394               (setq bucketkids
 395                     (mapcar (lambda (tok)
 396                               (funcall semantic-mark-external-member-function
 397                                        tok (car decent-list)))
 398                             bucketkids)))
 399           ;; We have some extra kids.  Merge.
 400           (semantic-tag-put-attribute
 401            (car decent-list) :members
 402            (append (semantic-tag-type-members (car decent-list))
 403                    bucketkids))
 404           ;; Nuke the bucket label so it is not found again.
 405           (setcar bucket nil))
 406         (setq decent-list
 407               (append (cdr decent-list)
 408                       ;; get embedded types to scan and make copies
 409                       ;; of them.
 410                       (mapcar
 411                        (lambda (tok) (semantic-tag-clone tok))
 412                        (semantic-find-tags-by-class 'type
 413                         (semantic-tag-type-members (car decent-list)))))
 414               )))
 415     ;; Scan over all remaining lost external methods, and tack them
 416     ;; onto the end.
 417     (while parent-buckets
 418       (if (car (car parent-buckets))
 419           (let* ((tmp (car parent-buckets))
 420                  (fauxtag (semantic-tag-new-type
 421                            (car tmp)
 422                            semantic-orphaned-member-metaparent-type
 423                            nil ;; Part list
 424                            nil ;; parents (unknown)
 425                            ))
 426                  (bucketkids (cdr tmp)))
 427             (semantic-tag-set-faux fauxtag) ;; properties
 428             (if semantic-mark-external-member-function
 429                 (setq bucketkids
 430                       (mapcar (lambda (tok)
 431                                 (funcall semantic-mark-external-member-function
 432                                          tok fauxtag))
 433                               bucketkids)))
 434             (semantic-tag-put-attribute fauxtag :members bucketkids)
 435             ;; We have a bunch of methods with no parent in this file.
 436             ;; Create a meta-type to hold it.
 437             (setq out (cons fauxtag out))
 438             ))
 439       (setq parent-buckets (cdr parent-buckets)))
 440     ;; Return the new list.
 441     (nreverse out)))
 442
 443 \f
 444 ;;; External children
 445 ;;
 446 ;; In order to adopt external children, we need a few overload methods
 447 ;; to enable the feature.
 448
 449 ;;;###autoload
 450 (define-overloadable-function semantic-tag-external-member-parent (tag)
 451   "Return a parent for TAG when TAG is an external member.
 452 TAG is an external member if it is defined at a toplevel and
 453 has some sort of label defining a parent.  The parent return will
 454 be a string.
 455
 456 The default behavior, if not overridden with
 457 `tag-member-parent' gets the 'parent extra
 458 specifier of TAG.
 459
 460 If this function is overridden, use
 461 `semantic-tag-external-member-parent-default' to also
 462 include the default behavior, and merely extend your own."
 463   )
 464
 465 (defun semantic-tag-external-member-parent-default (tag)
 466   "Return the name of TAGs parent only if TAG is not defined in its parent."
 467   ;; Use only the extra spec because a type has a parent which
 468   ;; means something completely different.
 469   (let ((tp (semantic-tag-get-attribute tag :parent)))
 470     (when (stringp tp)
 471       tp)))
 472
 473 (define-overloadable-function semantic-tag-external-member-p (parent tag)
 474   "Return non-nil if PARENT is the parent of TAG.
 475 TAG is an external member of PARENT when it is somehow tagged
 476 as having PARENT as its parent.
 477 PARENT and TAG must both be semantic tags.
 478
 479 The default behavior, if not overridden with
 480 `tag-external-member-p' is to match :parent attribute in
 481 the name of TAG.
 482
 483 If this function is overridden, use
 484 `semantic-tag-external-member-children-p-default' to also
 485 include the default behavior, and merely extend your own."
 486   )
 487
 488 (defun semantic-tag-external-member-p-default (parent tag)
 489   "Return non-nil if PARENT is the parent of TAG."
 490   ;; Use only the extra spec because a type has a parent which
 491   ;; means something completely different.
 492   (let ((tp (semantic-tag-external-member-parent tag)))
 493     (and (stringp tp)
 494          (string= (semantic-tag-name parent) tp))))
 495
 496 (define-overloadable-function semantic-tag-external-member-children (tag &optional usedb)
 497   "Return the list of children which are not *in* TAG.
 498 If optional argument USEDB is non-nil, then also search files in
 499 the Semantic Database.  If USEDB is a list of databases, search those
 500 databases.
 501
 502 Children in this case are functions or types which are members of
 503 TAG, such as the parts of a type, but which are not defined inside
 504 the class.  C++ and CLOS both permit methods of a class to be defined
 505 outside the bounds of the class' definition.
 506
 507 The default behavior, if not overridden with
 508 `tag-external-member-children' is to search using
 509 `semantic-tag-external-member-p' in all top level definitions
 510 with a parent of TAG.
 511
 512 If this function is overridden, use
 513 `semantic-tag-external-member-children-default' to also
 514 include the default behavior, and merely extend your own."
 515   )
 516
 517 (defun semantic-tag-external-member-children-default (tag &optional usedb)
 518   "Return list of external children for TAG.
 519 Optional argument USEDB specifies if the semantic database is used.
 520 See `semantic-tag-external-member-children' for details."
 521   (if (and usedb
 522            (require 'semantic/db-mode)
 523            (semanticdb-minor-mode-p)
 524            (require 'semantic/db-find))
 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 (define-overloadable-function semantic-tag-external-class (tag)
 537   "Return a list of real tags that faux TAG might represent.
 538
 539 In some languages, a method can be defined on an object which is
 540 not in the same file.  In this case,
 541 `semantic-adopt-external-members' will create a faux-tag.  If it
 542 is necessary to get the tag from which for faux TAG was most
 543 likely derived, then this function is needed."
 544   (unless (semantic-tag-faux-p tag)
 545     (signal 'wrong-type-argument (list tag 'semantic-tag-faux-p)))
 546   (:override)
 547   )
 548
 549 (defun semantic-tag-external-class-default (tag)
 550   "Return a list of real tags that faux TAG might represent.
 551 See `semantic-tag-external-class' for details."
 552   (if (and (require 'semantic/db-mode)
 553            (semanticdb-minor-mode-p))
 554       (let* ((semanticdb-search-system-databases nil)
 555              (m (semanticdb-find-tags-by-class
 556                  (semantic-tag-class tag)
 557                  (semanticdb-find-tags-by-name (semantic-tag-name tag)))))
 558         (semanticdb-strip-find-results m 'name))
 559     ;; Presumably, if the tag is faux, it is not local.
 560     nil))
 561
 562 (provide 'semantic/sort)
 563
 564 ;; Local variables:
 565 ;; generated-autoload-file: "loaddefs.el"
 566 ;; generated-autoload-load-name: "semantic/sort"
 567 ;; End:
 568
 569 ;; arch-tag: 9231c8e7-ac7f-4b35-9302-651a02e5fef0
 570 ;;; semantic-sort.el ends here