Source

semantic / semantic-sort.el

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
;;; semantic-sort.el --- Utilities for sorting and re-arranging tag tables.

;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007 Eric M. Ludlam

;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: syntax
;; X-RCS: $Id$

;; This file is not part of GNU Emacs.

;; Semantic 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 2, or (at your option)
;; any later version.

;; This software 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; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; 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 'semanticdb)
(eval-when-compile
  (require 'semantic-find)
  (require 'semanticdb-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 ""))))

;;;###autoload
(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)))))

;;;###autoload
(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)))))

;;;###autoload
(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)))))

;;;###autoload
(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)))))

;;;###autoload
(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)))))

;;;###autoload
(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)))))

;;;###autoload
(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)))))

;;;###autoload
(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)))))

(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.

;;;###autoload
(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."
  (let ((copy (copy-sequence tags))
	(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)))

;;;###autoload
(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."
  (let ((copy (copy-sequence tags))
	(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.

;;;###autoload
(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).")

;;;###autoload
(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.
;;
;;;###autoload
(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.")

;;;###autoload
(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.
;;
;;;###autoload
(define-overload 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)

;;;###autoload
(define-overload 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)

;;;###autoload
(define-overload 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))
    ))

;;;###autoload
(define-overload 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 t))
    ;; 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