aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorChong Yidong2009-08-29 19:00:35 +0000
committerChong Yidong2009-08-29 19:00:35 +0000
commit9573e58b233ac4210a2801b1263f39843d4e48a0 (patch)
treede2cb65f9b29559ce32b9c68d32ec4a44da70d23
parenta175a831d33f56cce1793a7593fb14178118b117 (diff)
downloademacs-9573e58b233ac4210a2801b1263f39843d4e48a0.tar.gz
emacs-9573e58b233ac4210a2801b1263f39843d4e48a0.zip
cedet/semantic/analyze.el, cedet/semantic/complete.el,
cedet/semantic/edit.el, cedet/semantic/html.el, cedet/semantic/idle.el, cedet/semantic/texi.el: New files. cedet/semantic/lex.el: Move defsubsts to front of file to avoid compiler error.
-rw-r--r--lisp/cedet/semantic/analyze.el769
-rw-r--r--lisp/cedet/semantic/complete.el2128
-rw-r--r--lisp/cedet/semantic/edit.el965
-rw-r--r--lisp/cedet/semantic/html.el262
-rw-r--r--lisp/cedet/semantic/idle.el957
-rw-r--r--lisp/cedet/semantic/lex.el66
-rw-r--r--lisp/cedet/semantic/texi.el677
7 files changed, 5794 insertions, 30 deletions
diff --git a/lisp/cedet/semantic/analyze.el b/lisp/cedet/semantic/analyze.el
new file mode 100644
index 00000000000..7c47ba0877c
--- /dev/null
+++ b/lisp/cedet/semantic/analyze.el
@@ -0,0 +1,769 @@
1;;; analyze.el --- Analyze semantic tags against local context
2
3;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009
4;;; Free Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24;;
25;; Semantic, as a tool, provides a nice list of searchable tags.
26;; That information can provide some very accurate answers if the current
27;; context of a position is known.
28;;
29;; Semantic-ctxt provides ways of analyzing, and manipulating the
30;; semantic context of a language in code.
31;;
32;; This library provides routines for finding intelligent answers to
33;; tough problems, such as if an argument to a function has the correct
34;; return type, or all possible tags that fit in a given local context.
35;;
36
37;;; Vocabulary:
38;;
39;; Here are some words used to describe different things in the analyzer:
40;;
41;; tag - A single entity
42;; prefix - The beginning of a symbol, usually used to look up something
43;; incomplete.
44;; type - The name of a datatype in the langauge.
45;; metatype - If a type is named in a declaration like:
46;; struct moose somevariable;
47;; that name "moose" can be turned into a concrete type.
48;; tag sequence - In C code, a list of dereferences, such as:
49;; this.that.theother();
50;; parent - For a datatype in an OO language, another datatype
51;; inherited from. This excludes interfaces.
52;; scope - A list of tags that can be dereferenced that cannot
53;; be found from the global namespace.
54;; scopetypes - A list of tags which are datatype that contain
55;; the scope. The scopetypes need to have the scope extracted
56;; in a way that honors the type of inheritance.
57;; nest/nested - When one tag is contained entirely in another.
58;;
59;; context - A semantic datatype representing a point in a buffer.
60;;
61;; constriant - If a context specifies a specific datatype is needed,
62;; that is a constraint.
63;; constants - Some datatypes define elements of themselves as a
64;; constant. These need to be returned as there would be no
65;; other possible completions.
66;;
67(require 'eieio)
68;; (require 'inversion)
69;; (eval-and-compile
70;; (inversion-require 'eieio "1.0"))
71(require 'semantic)
72(require 'semantic/format)
73(require 'semantic/ctxt)
74(require 'semantic/sort)
75(eval-when-compile (require 'semantic/db)
76 (require 'semantic/db-find))
77
78(require 'semantic/scope)
79(require 'semantic/analyze/fcn)
80
81;;; Code:
82(defvar semantic-analyze-error-stack nil
83 "Collection of any errors thrown during analysis.")
84
85(defun semantic-analyze-push-error (err)
86 "Push the error in ERR-DATA onto the error stack.
87Argument ERR"
88 (push err semantic-analyze-error-stack))
89
90;;; Analysis Classes
91;;
92;; These classes represent what a context is. Different types
93;; of contexts provide differing amounts of information to help
94;; provide completions.
95;;
96(defclass semantic-analyze-context ()
97 ((bounds :initarg :bounds
98 :type list
99 :documentation "The bounds of this context.
100Usually bound to the dimension of a single symbol or command.")
101 (prefix :initarg :prefix
102 :type list
103 :documentation "List of tags defining local text.
104This can be nil, or a list where the last element can be a string
105representing text that may be incomplete. Preceeding elements
106must be semantic tags representing variables or functions
107called in a dereference sequence.")
108 (prefixclass :initarg :prefixclass
109 :type list
110 :documentation "Tag classes expected at this context.
111These are clases for tags, such as 'function, or 'variable.")
112 (prefixtypes :initarg :prefixtypes
113 :type list
114 :documentation "List of tags defining types for :prefix.
115This list is one shorter than :prefix. Each element is a semantic
116tag representing a type matching the semantic tag in the same
117position in PREFIX.")
118 (scope :initarg :scope
119 :type (or null semantic-scope-cache)
120 :documentation "List of tags available in scopetype.
121See `semantic-analyze-scoped-tags' for details.")
122 (buffer :initarg :buffer
123 :type buffer
124 :documentation "The buffer this context is derived from.")
125 (errors :initarg :errors
126 :documentation "Any errors thrown an caught during analysis.")
127 )
128 "Base analysis data for a any context.")
129
130(defclass semantic-analyze-context-assignment (semantic-analyze-context)
131 ((assignee :initarg :assignee
132 :type list
133 :documentation "A sequence of tags for an assignee.
134This is a variable into which some value is being placed. The last
135item in the list is the variable accepting the value. Earlier
136tags represent the variables being derefernece to get to the
137assignee."))
138 "Analysis class for a value in an assignment.")
139
140(defclass semantic-analyze-context-functionarg (semantic-analyze-context)
141 ((function :initarg :function
142 :type list
143 :documentation "A sequence of tags for a function.
144This is a function being called. The cursor will be in the position
145of an argument.
146The last tag in :function is the function being called. Earlier
147tags represent the variables being dereferenced to get to the
148function.")
149 (index :initarg :index
150 :type integer
151 :documentation "The index of the argument for this context.
152If a function takes 4 arguments, this value should be bound to
153the values 1 through 4.")
154 (argument :initarg :argument
155 :type list
156 :documentation "A sequence of tags for the :index argument.
157The argument can accept a value of some type, and this contains the
158tag for that definition. It should be a tag, but might
159be just a string in some circumstances.")
160 )
161 "Analysis class for a value as a function argument.")
162
163(defclass semantic-analyze-context-return (semantic-analyze-context)
164 () ; No extra data.
165 "Analysis class for return data.
166Return data methods identify the requred type by the return value
167of the parent function.")
168
169;;; METHODS
170;;
171;; Simple methods against the context classes.
172;;
173(defmethod semantic-analyze-type-constraint
174 ((context semantic-analyze-context) &optional desired-type)
175 "Return a type constraint for completing :prefix in CONTEXT.
176Optional argument DESIRED-TYPE may be a non-type tag to analyze."
177 (when (semantic-tag-p desired-type)
178 ;; Convert the desired type if needed.
179 (if (not (eq (semantic-tag-class desired-type) 'type))
180 (setq desired-type (semantic-tag-type desired-type)))
181 ;; Protect against plain strings
182 (cond ((stringp desired-type)
183 (setq desired-type (list desired-type 'type)))
184 ((and (stringp (car desired-type))
185 (not (semantic-tag-p desired-type)))
186 (setq desired-type (list (car desired-type) 'type)))
187 ((semantic-tag-p desired-type)
188 ;; We have a tag of some sort. Yay!
189 nil)
190 (t (setq desired-type nil))
191 )
192 desired-type))
193
194(defmethod semantic-analyze-type-constraint
195 ((context semantic-analyze-context-functionarg))
196 "Return a type constraint for completing :prefix in CONTEXT."
197 (call-next-method context (car (oref context argument))))
198
199(defmethod semantic-analyze-type-constraint
200 ((context semantic-analyze-context-assignment))
201 "Return a type constraint for completing :prefix in CONTEXT."
202 (call-next-method context (car (reverse (oref context assignee)))))
203
204(defmethod semantic-analyze-interesting-tag
205 ((context semantic-analyze-context))
206 "Return a tag from CONTEXT that would be most interesting to a user."
207 (let ((prefix (reverse (oref context :prefix))))
208 ;; Go back through the prefix until we find a tag we can return.
209 (while (and prefix (not (semantic-tag-p (car prefix))))
210 (setq prefix (cdr prefix)))
211 ;; Return the found tag, or nil.
212 (car prefix)))
213
214(defmethod semantic-analyze-interesting-tag
215 ((context semantic-analyze-context-functionarg))
216 "Try the base, and if that fails, return what we are assigning into."
217 (or (call-next-method) (car-safe (oref context :function))))
218
219(defmethod semantic-analyze-interesting-tag
220 ((context semantic-analyze-context-assignment))
221 "Try the base, and if that fails, return what we are assigning into."
222 (or (call-next-method) (car-safe (oref context :assignee))))
223
224;;; ANALYSIS
225;;
226;; Start out with routines that will calculate useful parts of
227;; the general analyzer function. These could be used directly
228;; by an application that doesn't need to calculate the full
229;; context.
230
231(define-overloadable-function semantic-analyze-find-tag-sequence (sequence &optional
232 scope typereturn throwsym)
233 "Attempt to find all tags in SEQUENCE.
234Optional argument LOCALVAR is the list of local variables to use when
235finding the details on the first element of SEQUENCE in case
236it is not found in the global set of tables.
237Optional argument SCOPE are additional terminals to search which are currently
238scoped. These are not local variables, but symbols available in a structure
239which doesn't need to be dereferneced.
240Optional argument TYPERETURN is a symbol in which the types of all found
241will be stored. If nil, that data is thrown away.
242Optional argument THROWSYM specifies a symbol the throw on non-recoverable error.")
243
244(defun semantic-analyze-find-tag-sequence-default (sequence &optional
245 scope typereturn
246 throwsym)
247 "Attempt to find all tags in SEQUENCE.
248SCOPE are extra tags which are in scope.
249TYPERETURN is a symbol in which to place a list of tag classes that
250are found in SEQUENCE.
251Optional argument THROWSYM specifies a symbol the throw on non-recoverable error."
252 (let ((s sequence) ; copy of the sequence
253 (tmp nil) ; tmp find variable
254 (tag nil) ; tag return list
255 (tagtype nil) ; tag types return list
256 (fname nil)
257 (miniscope (clone scope))
258 )
259 ;; First order check. Is this wholely contained in the typecache?
260 (setq tmp (semanticdb-typecache-find sequence))
261
262 (if tmp
263 (progn
264 ;; We are effectively done...
265 (setq s nil)
266 (setq tag (list tmp)))
267
268 ;; For the first entry, it better be a variable, but it might
269 ;; be in the local context too.
270 ;; NOTE: Don't forget c++ namespace foo::bar.
271 (setq tmp (or
272 ;; Is this tag within our scope. Scopes can sometimes
273 ;; shadow other things, so it goes first.
274 (and scope (semantic-scope-find (car s) nil scope))
275 ;; Find the tag out there... somewhere, but not in scope
276 (semantic-analyze-find-tag (car s))
277 ))
278
279 (if (and (listp tmp) (semantic-tag-p (car tmp)))
280 (setq tmp (semantic-analyze-select-best-tag tmp)))
281 (if (not (semantic-tag-p tmp))
282 (if throwsym
283 (throw throwsym "Cannot find definition")
284 (error "Cannot find definition for \"%s\"" (car s))))
285 (setq s (cdr s))
286 (setq tag (cons tmp tag)) ; tag is nil here...
287 (setq fname (semantic-tag-file-name tmp))
288 )
289
290 ;; For the middle entries
291 (while s
292 ;; Using the tag found in TMP, lets find the tag
293 ;; representing the full typeographic information of its
294 ;; type, and use that to determine the search context for
295 ;; (car s)
296 (let* ((tmptype
297 ;; In some cases the found TMP is a type,
298 ;; and we can use it directly.
299 (cond ((semantic-tag-of-class-p tmp 'type)
300 ;; update the miniscope when we need to analyze types directly.
301 (let ((rawscope
302 (apply 'append
303 (mapcar 'semantic-tag-type-members
304 tagtype))))
305 (oset miniscope fullscope rawscope))
306 ;; Now analayze the type to remove metatypes.
307 (or (semantic-analyze-type tmp miniscope)
308 tmp))
309 (t
310 (semantic-analyze-tag-type tmp scope))))
311 (typefile
312 (when tmptype
313 (semantic-tag-file-name tmptype)))
314 (slots nil))
315
316 ;; Get the children
317 (setq slots (semantic-analyze-scoped-type-parts tmptype scope))
318
319 ;; find (car s) in the list o slots
320 (setq tmp (semantic-find-tags-by-name (car s) slots))
321
322 ;; If we have lots
323 (if (and (listp tmp) (semantic-tag-p (car tmp)))
324 (setq tmp (semantic-analyze-select-best-tag tmp)))
325
326 ;; Make sure we have a tag.
327 (if (not (semantic-tag-p tmp))
328 (if (cdr s)
329 ;; In the middle, we need to keep seeking our types out.
330 (error "Cannot find definition for \"%s\"" (car s))
331 ;; Else, it's ok to end with a non-tag
332 (setq tmp (car s))))
333
334 (setq fname (or typefile fname))
335 (when (and fname (semantic-tag-p tmp)
336 (not (semantic-tag-in-buffer-p tmp)))
337 (semantic--tag-put-property tmp :filename fname))
338 (setq tag (cons tmp tag))
339 (setq tagtype (cons tmptype tagtype))
340 )
341 (setq s (cdr s)))
342
343 (if typereturn (set typereturn (nreverse tagtype)))
344 ;; Return the mess
345 (nreverse tag)))
346
347(defun semantic-analyze-find-tag (name &optional tagclass scope)
348 "Return the first tag found with NAME or nil if not found.
349Optional argument TAGCLASS specifies the class of tag to return, such
350as 'function or 'variable.
351Optional argument SCOPE specifies a scope object which has
352additional tags which are in SCOPE and do not need prefixing to
353find.
354
355This is a wrapper on top of semanticdb, semanticdb-typecache,
356semantic-scope, and semantic search functions. Almost all
357searches use the same arguments."
358 (let ((namelst (if (consp name) name ;; test if pre-split.
359 (semantic-analyze-split-name name))))
360 (cond
361 ;; If the splitter gives us a list, use the sequence finder
362 ;; to get the list. Since this routine is expected to return
363 ;; only one tag, return the LAST tag found from the sequence
364 ;; which is supposedly the nested reference.
365 ;;
366 ;; Of note, the SEQUENCE function below calls this function
367 ;; (recursively now) so the names that we get from the above
368 ;; fcn better not, in turn, be splittable.
369 ((listp namelst)
370 ;; If we had a split, then this is likely a c++ style namespace::name sequence,
371 ;; so take a short-cut through the typecache.
372 (or (semanticdb-typecache-find namelst)
373 ;; Ok, not there, try the usual...
374 (let ((seq (semantic-analyze-find-tag-sequence
375 namelst scope nil)))
376 (semantic-analyze-select-best-tag seq tagclass)
377 )))
378 ;; If NAME is solo, then do our searches for it here.
379 ((stringp namelst)
380 (let ((retlist (and scope (semantic-scope-find name tagclass scope))))
381 (if retlist
382 (semantic-analyze-select-best-tag
383 retlist tagclass)
384 (if (eq tagclass 'type)
385 (semanticdb-typecache-find name)
386 ;; Search in the typecache. First entries in a sequence are
387 ;; often there.
388 (setq retlist (semanticdb-typecache-find name))
389 (if retlist
390 retlist
391 (semantic-analyze-select-best-tag
392 (semanticdb-strip-find-results
393 (semanticdb-find-tags-by-name name)
394 'name)
395 tagclass)
396 )))))
397 )))
398
399;;; SHORT ANALYSIS
400;;
401;; Create a mini-analysis of just the symbol under point.
402;;
403(define-overloadable-function semantic-analyze-current-symbol
404 (analyzehookfcn &optional position)
405 "Call ANALYZEHOOKFCN after analyzing the symbol under POSITION.
406The ANALYZEHOOKFCN is called with the current symbol bounds, and the
407analyzed prefix. It should take the arguments (START END PREFIX).
408The ANALYZEHOOKFCN is only called if some sort of prefix with bounds was
409found under POSITION.
410
411The results of ANALYZEHOOKFCN is returned, or nil if there was nothing to
412call it with.
413
414For regular analysis, you should call `semantic-analyze-current-context'
415to calculate the context information. The purpose for this function is
416to provide a large number of non-cached analysis for filtering symbols."
417 ;; Only do this in a Semantic enabled buffer.
418 (when (not (semantic-active-p))
419 (error "Cannot analyze buffers not supported by Semantic."))
420 ;; Always refresh out tags in a safe way before doing the
421 ;; context.
422 (semantic-refresh-tags-safe)
423 ;; Do the rest of the analysis.
424 (save-match-data
425 (save-excursion
426 (:override)))
427 )
428
429(defun semantic-analyze-current-symbol-default (analyzehookfcn position)
430 "Call ANALYZEHOOKFCN on the analyzed symbol at POSITION."
431 (let* ((semantic-analyze-error-stack nil)
432 (LLstart (current-time))
433 (prefixandbounds (semantic-ctxt-current-symbol-and-bounds (or position (point))))
434 (prefix (car prefixandbounds))
435 (bounds (nth 2 prefixandbounds))
436 (scope (semantic-calculate-scope position))
437 (end nil)
438 )
439 ;; Only do work if we have bounds (meaning a prefix to complete)
440 (when bounds
441
442 (if debug-on-error
443 (catch 'unfindable
444 ;; If debug on error is on, allow debugging in this fcn.
445 (setq prefix (semantic-analyze-find-tag-sequence
446 prefix scope 'prefixtypes 'unfindable)))
447 ;; Debug on error is off. Capture errors and move on
448 (condition-case err
449 ;; NOTE: This line is duplicated in
450 ;; semantic-analyzer-debug-global-symbol
451 ;; You will need to update both places.
452 (setq prefix (semantic-analyze-find-tag-sequence
453 prefix scope 'prefixtypes))
454 (error (semantic-analyze-push-error err))))
455
456 (setq end (current-time))
457 ;;(message "Analysis took %.2f sec" (semantic-elapsed-time LLstart end))
458
459 )
460 (when prefix
461 (prog1
462 (funcall analyzehookfcn (car bounds) (cdr bounds) prefix)
463 ;;(setq end (current-time))
464 ;;(message "hookfcn took %.5f sec" (semantic-elapsed-time LLstart end))
465 )
466
467 )))
468
469;;; MAIN ANALYSIS
470;;
471;; Create a full-up context analysis.
472;;
473(define-overloadable-function semantic-analyze-current-context (&optional position)
474 "Analyze the current context at optional POSITION.
475If called interactively, display interesting information about POSITION
476in a separate buffer.
477Returns an object based on symbol `semantic-analyze-context'.
478
479This function can be overriden with the symbol `analyze-context'.
480When overriding this function, your override will be called while
481cursor is at POSITION. In addition, your function will not be called
482if a cached copy of the return object is found."
483 (interactive "d")
484 ;; Only do this in a Semantic enabled buffer.
485 (when (not (semantic-active-p))
486 (error "Cannot analyze buffers not supported by Semantic."))
487 ;; Always refresh out tags in a safe way before doing the
488 ;; context.
489 (semantic-refresh-tags-safe)
490 ;; Do the rest of the analysis.
491 (if (not position) (setq position (point)))
492 (save-excursion
493 (goto-char position)
494 (let* ((answer (semantic-get-cache-data 'current-context)))
495 (with-syntax-table semantic-lex-syntax-table
496 (when (not answer)
497 (setq answer (:override))
498 (when (and answer (oref answer bounds))
499 (with-slots (bounds) answer
500 (semantic-cache-data-to-buffer (current-buffer)
501 (car bounds)
502 (cdr bounds)
503 answer
504 'current-context
505 'exit-cache-zone)))
506 ;; Check for interactivity
507 (when (interactive-p)
508 (if answer
509 (semantic-analyze-pop-to-context answer)
510 (message "No Context."))
511 ))
512
513 answer))))
514
515(defun semantic-analyze-current-context-default (position)
516 "Analyze the current context at POSITION.
517Returns an object based on symbol `semantic-analyze-context'."
518 (let* ((semantic-analyze-error-stack nil)
519 (context-return nil)
520 (prefixandbounds (semantic-ctxt-current-symbol-and-bounds (or position (point))))
521 (prefix (car prefixandbounds))
522 (bounds (nth 2 prefixandbounds))
523 ;; @todo - vv too early to really know this answer! vv
524 (prefixclass (semantic-ctxt-current-class-list))
525 (prefixtypes nil)
526 (scope (semantic-calculate-scope position))
527 (function nil)
528 (fntag nil)
529 arg fntagend argtag
530 assign asstag
531 )
532
533 ;; Pattern for Analysis:
534 ;;
535 ;; Step 1: Calculate DataTypes in Scope:
536 ;;
537 ;; a) Calculate the scope (above)
538 ;;
539 ;; Step 2: Parse context
540 ;;
541 ;; a) Identify function being called, or variable assignment,
542 ;; and find source tags for those references
543 ;; b) Identify the prefix (text cursor is on) and find the source
544 ;; tags for those references.
545 ;;
546 ;; Step 3: Assemble an object
547 ;;
548
549 ;; Step 2 a:
550
551 (setq function (semantic-ctxt-current-function))
552
553 (when function
554 ;; Calculate the argument for the function if there is one.
555 (setq arg (semantic-ctxt-current-argument))
556
557 ;; Find a tag related to the function name.
558 (condition-case err
559 (setq fntag
560 (semantic-analyze-find-tag-sequence function scope))
561 (error (semantic-analyze-push-error err)))
562
563 ;; fntag can have the last entry as just a string, meaning we
564 ;; could not find the core datatype. In this case, the searches
565 ;; below will not work.
566 (when (stringp (car (last fntag)))
567 ;; Take a wild guess!
568 (setcar (last fntag) (semantic-tag (car (last fntag)) 'function))
569 )
570
571 (when fntag
572 (let ((fcn (semantic-find-tags-by-class 'function fntag)))
573 (when (not fcn)
574 (let ((ty (semantic-find-tags-by-class 'type fntag)))
575 (when ty
576 ;; We might have a constructor with the same name as
577 ;; the found datatype.
578 (setq fcn (semantic-find-tags-by-name
579 (semantic-tag-name (car ty))
580 (semantic-tag-type-members (car ty))))
581 (if fcn
582 (let ((lp fcn))
583 (while lp
584 (when (semantic-tag-get-attribute (car lp)
585 :constructor)
586 (setq fcn (cons (car lp) fcn)))
587 (setq lp (cdr lp))))
588 ;; Give up, go old school
589 (setq fcn fntag))
590 )))
591 (setq fntagend (car (reverse fcn))
592 argtag
593 (when (semantic-tag-p fntagend)
594 (nth (1- arg) (semantic-tag-function-arguments fntagend)))
595 fntag fcn))))
596
597 ;; Step 2 b:
598
599 ;; Only do work if we have bounds (meaning a prefix to complete)
600 (when bounds
601
602 (if debug-on-error
603 (catch 'unfindable
604 ;; If debug on error is on, allow debugging in this fcn.
605 (setq prefix (semantic-analyze-find-tag-sequence
606 prefix scope 'prefixtypes 'unfindable)))
607 ;; Debug on error is off. Capture errors and move on
608 (condition-case err
609 ;; NOTE: This line is duplicated in
610 ;; semantic-analyzer-debug-global-symbol
611 ;; You will need to update both places.
612 (setq prefix (semantic-analyze-find-tag-sequence
613 prefix scope 'prefixtypes))
614 (error (semantic-analyze-push-error err))))
615 )
616
617 ;; Step 3:
618
619 (cond
620 (fntag
621 ;; If we found a tag for our function, we can go into
622 ;; functional context analysis mode, meaning we have a type
623 ;; for the argument.
624 (setq context-return
625 (semantic-analyze-context-functionarg
626 "functionargument"
627 :buffer (current-buffer)
628 :function fntag
629 :index arg
630 :argument (list argtag)
631 :scope scope
632 :prefix prefix
633 :prefixclass prefixclass
634 :bounds bounds
635 :prefixtypes prefixtypes
636 :errors semantic-analyze-error-stack)))
637
638 ;; No function, try assignment
639 ((and (setq assign (semantic-ctxt-current-assignment))
640 ;; We have some sort of an assignment
641 (condition-case err
642 (setq asstag (semantic-analyze-find-tag-sequence
643 assign scope))
644 (error (semantic-analyze-push-error err)
645 nil)))
646
647 (setq context-return
648 (semantic-analyze-context-assignment
649 "assignment"
650 :buffer (current-buffer)
651 :assignee asstag
652 :scope scope
653 :bounds bounds
654 :prefix prefix
655 :prefixclass prefixclass
656 :prefixtypes prefixtypes
657 :errors semantic-analyze-error-stack)))
658
659 ;; TODO: Identify return value condition.
660 ;;((setq return .... what to do?)
661 ;; ...)
662
663 (bounds
664 ;; Nothing in particular
665 (setq context-return
666 (semantic-analyze-context
667 "context"
668 :buffer (current-buffer)
669 :scope scope
670 :bounds bounds
671 :prefix prefix
672 :prefixclass prefixclass
673 :prefixtypes prefixtypes
674 :errors semantic-analyze-error-stack)))
675
676 (t (setq context-return nil))
677 )
678
679 ;; Return our context.
680 context-return))
681
682
683;;; DEBUG OUTPUT
684;;
685;; Friendly output of a context analysis.
686;;
687(defmethod semantic-analyze-pulse ((context semantic-analyze-context))
688 "Pulse the region that CONTEXT affects."
689 (save-excursion
690 (set-buffer (oref context :buffer))
691 (let ((bounds (oref context :bounds)))
692 (when bounds
693 (pulse-momentary-highlight-region (car bounds) (cdr bounds))))))
694
695(defcustom semantic-analyze-summary-function 'semantic-format-tag-prototype
696 "*Function to use when creating items in Imenu.
697Some useful functions are found in `semantic-format-tag-functions'."
698 :group 'semantic
699 :type semantic-format-tag-custom-list)
700
701(defun semantic-analyze-princ-sequence (sequence &optional prefix buff)
702 "Send the tag SEQUENCE to standard out.
703Use PREFIX as a label.
704Use BUFF as a source of override methods."
705 (while sequence
706 (princ prefix)
707 (cond
708 ((semantic-tag-p (car sequence))
709 (princ (funcall semantic-analyze-summary-function
710 (car sequence))))
711 ((stringp (car sequence))
712 (princ "\"")
713 (princ (semantic--format-colorize-text (car sequence) 'variable))
714 (princ "\""))
715 (t
716 (princ (format "'%S" (car sequence)))))
717 (princ "\n")
718 (setq sequence (cdr sequence))
719 (setq prefix (make-string (length prefix) ? ))
720 ))
721
722(defmethod semantic-analyze-show ((context semantic-analyze-context))
723 "Insert CONTEXT into the current buffer in a nice way."
724 (semantic-analyze-princ-sequence (oref context prefix) "Prefix: " )
725 (semantic-analyze-princ-sequence (oref context prefixclass) "Prefix Classes: ")
726 (semantic-analyze-princ-sequence (oref context prefixtypes) "Prefix Types: ")
727 (semantic-analyze-princ-sequence (oref context errors) "Encountered Errors: ")
728 (princ "--------\n")
729 ;(semantic-analyze-princ-sequence (oref context scopetypes) "Scope Types: ")
730 ;(semantic-analyze-princ-sequence (oref context scope) "Scope: ")
731 ;(semantic-analyze-princ-sequence (oref context localvariables) "LocalVars: ")
732 (when (oref context scope)
733 (semantic-analyze-show (oref context scope)))
734 )
735
736(defmethod semantic-analyze-show ((context semantic-analyze-context-assignment))
737 "Insert CONTEXT into the current buffer in a nice way."
738 (semantic-analyze-princ-sequence (oref context assignee) "Assignee: ")
739 (call-next-method))
740
741(defmethod semantic-analyze-show ((context semantic-analyze-context-functionarg))
742 "Insert CONTEXT into the current buffer in a nice way."
743 (semantic-analyze-princ-sequence (oref context function) "Function: ")
744 (princ "Argument Index: ")
745 (princ (oref context index))
746 (princ "\n")
747 (semantic-analyze-princ-sequence (oref context argument) "Argument: ")
748 (call-next-method))
749
750(defun semantic-analyze-pop-to-context (context)
751 "Display CONTEXT in a temporary buffer.
752CONTEXT's content is described in `semantic-analyze-current-context'."
753 (semantic-analyze-pulse context)
754 (with-output-to-temp-buffer "*Semantic Context Analysis*"
755 (princ "Context Type: ")
756 (princ (object-name context))
757 (princ "\n")
758 (princ "Bounds: ")
759 (princ (oref context bounds))
760 (princ "\n")
761 (semantic-analyze-show context)
762 )
763 (shrink-window-if-larger-than-buffer
764 (get-buffer-window "*Semantic Context Analysis*"))
765 )
766
767(provide 'semantic/analyze)
768
769;;; semantic-analyze.el ends here
diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el
new file mode 100644
index 00000000000..d1367e30b7d
--- /dev/null
+++ b/lisp/cedet/semantic/complete.el
@@ -0,0 +1,2128 @@
1;;; complete.el --- Routines for performing tag completion
2
3;;; Copyright (C) 2003, 2004, 2005, 2007, 2008, 2009
4;;; 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;; Completion of tags by name using tables of semantic generated tags.
27;;
28;; While it would be a simple matter of flattening all tag known
29;; tables to perform completion across them using `all-completions',
30;; or `try-completion', that process would be slow. In particular,
31;; when a system database is included in the mix, the potential for a
32;; ludicrous number of options becomes apparent.
33;;
34;; As such, dynamically searching across tables using a prefix,
35;; regular expression, or other feature is needed to help find symbols
36;; quickly without resorting to "show me every possible option now".
37;;
38;; In addition, some symbol names will appear in multiple locations.
39;; If it is important to distiguish, then a way to provide a choice
40;; over these locations is important as well.
41;;
42;; Beyond brute force offers for completion of plain strings,
43;; using the smarts of semantic-analyze to provide reduced lists of
44;; symbols, or fancy tabbing to zoom into files to show multiple hits
45;; of the same name can be provided.
46;;
47;;; How it works:
48;;
49;; There are several parts of any completion engine. They are:
50;;
51;; A. Collection of possible hits
52;; B. Typing or selecting an option
53;; C. Displaying possible unique completions
54;; D. Using the result
55;;
56;; Here, we will treat each section separately (excluding D)
57;; They can then be strung together in user-visible commands to
58;; fullfill specific needs.
59;;
60;; COLLECTORS:
61;;
62;; A collector is an object which represents the means by which tags
63;; to complete on are collected. It's first job is to find all the
64;; tags which are to be completed against. It can also rename
65;; some tags if needed so long as `semantic-tag-clone' is used.
66;;
67;; Some collectors will gather all tags to complete against first
68;; (for in buffer queries, or other small list situations). It may
69;; choose to do a broad search on each completion request. Built in
70;; functionality automatically focuses the cache in as the user types.
71;;
72;; A collector choosing to create and rename tags could choose a
73;; plain name format, a postfix name such as method:class, or a
74;; prefix name such as class.method.
75;;
76;; DISPLAYORS
77;;
78;; A displayor is in charge if showing the user interesting things
79;; about available completions, and can optionally provide a focus.
80;; The simplest display just lists all available names in a separate
81;; window. It may even choose to show short names when there are
82;; many to choose from, or long names when there are fewer.
83;;
84;; A complex displayor could opt to help the user 'focus' on some
85;; range. For example, if 4 tags all have the same name, subsequent
86;; calls to the displayor may opt to show each tag one at a time in
87;; the buffer. When the user likes one, selection would cause the
88;; 'focus' item to be selected.
89;;
90;; CACHE FORMAT
91;;
92;; The format of the tag lists used to perform the completions are in
93;; semanticdb "find" format, like this:
94;;
95;; ( ( DBTABLE1 TAG1 TAG2 ...)
96;; ( DBTABLE2 TAG1 TAG2 ...)
97;; ... )
98;;
99;; INLINE vs MINIBUFFER
100;;
101;; Two major ways completion is used in Emacs is either through a
102;; minibuffer query, or via completion in a normal editing buffer,
103;; encompassing some small range of characters.
104;;
105;; Structure for both types of completion are provided here.
106;; `semantic-complete-read-tag-engine' will use the minibuffer.
107;; `semantic-complete-inline-tag-engine' will complete text in
108;; a buffer.
109
110(require 'eieio)
111(require 'semantic/tag)
112(require 'semantic/find)
113(require 'semantic/analyze)
114(require 'semantic/format)
115(require 'semantic/ctxt)
116;; Keep semanticdb optional.
117(eval-when-compile
118 (require 'semantic/db)
119 (require 'semantic/db-find))
120
121(eval-when-compile
122 (condition-case nil
123 ;; Tooltip not available in older emacsen.
124 (require 'tooltip)
125 (error nil))
126 )
127
128;;; Code:
129
130;;; Compatibility
131;;
132(if (fboundp 'minibuffer-contents)
133 (eval-and-compile (defalias 'semantic-minibuffer-contents 'minibuffer-contents))
134 (eval-and-compile (defalias 'semantic-minibuffer-contents 'buffer-string)))
135(if (fboundp 'delete-minibuffer-contents)
136 (eval-and-compile (defalias 'semantic-delete-minibuffer-contents 'delete-minibuffer-contents))
137 (eval-and-compile (defalias 'semantic-delete-minibuffer-contents 'erase-buffer)))
138
139(defvar semantic-complete-inline-overlay nil
140 "The overlay currently active while completing inline.")
141
142(defun semantic-completion-inline-active-p ()
143 "Non-nil if inline completion is active."
144 (when (and semantic-complete-inline-overlay
145 (not (semantic-overlay-live-p semantic-complete-inline-overlay)))
146 (semantic-overlay-delete semantic-complete-inline-overlay)
147 (setq semantic-complete-inline-overlay nil))
148 semantic-complete-inline-overlay)
149
150;;; ------------------------------------------------------------
151;;; MINIBUFFER or INLINE utils
152;;
153(defun semantic-completion-text ()
154 "Return the text that is currently in the completion buffer.
155For a minibuffer prompt, this is the minibuffer text.
156For inline completion, this is the text wrapped in the inline completion
157overlay."
158 (if semantic-complete-inline-overlay
159 (semantic-complete-inline-text)
160 (semantic-minibuffer-contents)))
161
162(defun semantic-completion-delete-text ()
163 "Delete the text that is actively being completed.
164Presumably if you call this you will insert something new there."
165 (if semantic-complete-inline-overlay
166 (semantic-complete-inline-delete-text)
167 (semantic-delete-minibuffer-contents)))
168
169(defun semantic-completion-message (fmt &rest args)
170 "Display the string FMT formatted with ARGS at the end of the minibuffer."
171 (if semantic-complete-inline-overlay
172 (apply 'message fmt args)
173 (message (concat (buffer-string) (apply 'format fmt args)))))
174
175;;; ------------------------------------------------------------
176;;; MINIBUFFER: Option Selection harnesses
177;;
178(defvar semantic-completion-collector-engine nil
179 "The tag collector for the current completion operation.
180Value should be an object of a subclass of
181`semantic-completion-engine-abstract'.")
182
183(defvar semantic-completion-display-engine nil
184 "The tag display engine for the current completion operation.
185Value should be a ... what?")
186
187(defvar semantic-complete-key-map
188 (let ((km (make-sparse-keymap)))
189 (define-key km " " 'semantic-complete-complete-space)
190 (define-key km "\t" 'semantic-complete-complete-tab)
191 (define-key km "\C-m" 'semantic-complete-done)
192 (define-key km "\C-g" 'abort-recursive-edit)
193 (define-key km "\M-n" 'next-history-element)
194 (define-key km "\M-p" 'previous-history-element)
195 (define-key km "\C-n" 'next-history-element)
196 (define-key km "\C-p" 'previous-history-element)
197 ;; Add history navigation
198 km)
199 "Keymap used while completing across a list of tags.")
200
201(defvar semantic-completion-default-history nil
202 "Default history variable for any unhistoried prompt.
203Keeps STRINGS only in the history.")
204
205
206(defun semantic-complete-read-tag-engine (collector displayor prompt
207 default-tag initial-input
208 history)
209 "Read a semantic tag, and return a tag for the selection.
210Argument COLLECTOR is an object which can be used to to calculate
211a list of possible hits. See `semantic-completion-collector-engine'
212for details on COLLECTOR.
213Argumeng DISPLAYOR is an object used to display a list of possible
214completions for a given prefix. See`semantic-completion-display-engine'
215for details on DISPLAYOR.
216PROMPT is a string to prompt with.
217DEFAULT-TAG is a semantic tag or string to use as the default value.
218If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
219HISTORY is a symbol representing a variable to story the history in."
220 (let* ((semantic-completion-collector-engine collector)
221 (semantic-completion-display-engine displayor)
222 (semantic-complete-active-default nil)
223 (semantic-complete-current-matched-tag nil)
224 (default-as-tag (semantic-complete-default-to-tag default-tag))
225 (default-as-string (when (semantic-tag-p default-as-tag)
226 (semantic-tag-name default-as-tag)))
227 )
228
229 (when default-as-string
230 ;; Add this to the prompt.
231 ;;
232 ;; I really want to add a lookup of the symbol in those
233 ;; tags available to the collector and only add it if it
234 ;; is available as a possibility, but I'm too lazy right
235 ;; now.
236 ;;
237
238 ;; @todo - move from () to into the editable area
239 (if (string-match ":" prompt)
240 (setq prompt (concat
241 (substring prompt 0 (match-beginning 0))
242 " (" default-as-string ")"
243 (substring prompt (match-beginning 0))))
244 (setq prompt (concat prompt " (" default-as-string "): "))))
245 ;;
246 ;; Perform the Completion
247 ;;
248 (unwind-protect
249 (read-from-minibuffer prompt
250 initial-input
251 semantic-complete-key-map
252 nil
253 (or history
254 'semantic-completion-default-history)
255 default-tag)
256 (semantic-collector-cleanup semantic-completion-collector-engine)
257 (semantic-displayor-cleanup semantic-completion-display-engine)
258 )
259 ;;
260 ;; Extract the tag from the completion machinery.
261 ;;
262 semantic-complete-current-matched-tag
263 ))
264
265
266;;; Util for basic completion prompts
267;;
268
269(defvar semantic-complete-active-default nil
270 "The current default tag calculated for this prompt.")
271
272(defun semantic-complete-default-to-tag (default)
273 "Convert a calculated or passed in DEFAULT into a tag."
274 (if (semantic-tag-p default)
275 ;; Just return what was passed in.
276 (setq semantic-complete-active-default default)
277 ;; If none was passed in, guess.
278 (if (null default)
279 (setq default (semantic-ctxt-current-thing)))
280 (if (null default)
281 ;; Do nothing
282 nil
283 ;; Turn default into something useful.
284 (let ((str
285 (cond
286 ;; Semantic-ctxt-current-symbol will return a list of
287 ;; strings. Technically, we should use the analyzer to
288 ;; fully extract what we need, but for now, just grab the
289 ;; first string
290 ((and (listp default) (stringp (car default)))
291 (car default))
292 ((stringp default)
293 default)
294 ((symbolp default)
295 (symbol-name default))
296 (t
297 (signal 'wrong-type-argument
298 (list default 'semantic-tag-p)))))
299 (tag nil))
300 ;; Now that we have that symbol string, look it up using the active
301 ;; collector. If we get a match, use it.
302 (save-excursion
303 (semantic-collector-calculate-completions
304 semantic-completion-collector-engine
305 str nil))
306 ;; Do we have the perfect match???
307 (let ((ml (semantic-collector-current-exact-match
308 semantic-completion-collector-engine)))
309 (when ml
310 ;; We don't care about uniqueness. Just guess for convenience
311 (setq tag (semanticdb-find-result-nth-in-buffer ml 0))))
312 ;; save it
313 (setq semantic-complete-active-default tag)
314 ;; Return it.. .whatever it may be
315 tag))))
316
317
318;;; Prompt Return Value
319;;
320;; Getting a return value out of this completion prompt is a bit
321;; challenging. The read command returns the string typed in.
322;; We need to convert this into a valid tag. We can exit the minibuffer
323;; for different reasons. If we purposely exit, we must make sure
324;; the focused tag is calculated... preferably once.
325(defvar semantic-complete-current-matched-tag nil
326 "Variable used to pass the tags being matched to the prompt.")
327
328(defun semantic-complete-current-match ()
329 "Calculate a match from the current completion environment.
330Save this in our completion variable. Make sure that variable
331is cleared if any other keypress is made.
332Return value can be:
333 tag - a single tag that has been matched.
334 string - a message to show in the minibuffer."
335 ;; Query the environment for an active completion.
336 (let ((collector semantic-completion-collector-engine)
337 (displayor semantic-completion-display-engine)
338 (contents (semantic-completion-text))
339 matchlist
340 answer)
341 (if (string= contents "")
342 ;; The user wants the defaults!
343 (setq answer semantic-complete-active-default)
344 ;; This forces a full calculation of completion on CR.
345 (save-excursion
346 (semantic-collector-calculate-completions collector contents nil))
347 (semantic-complete-try-completion)
348 (cond
349 ;; Input match displayor focus entry
350 ((setq answer (semantic-displayor-current-focus displayor))
351 ;; We have answer, continue
352 )
353 ;; One match from the collector
354 ((setq matchlist (semantic-collector-current-exact-match collector))
355 (if (= (semanticdb-find-result-length matchlist) 1)
356 (setq answer (semanticdb-find-result-nth-in-buffer matchlist 0))
357 (if (semantic-displayor-focus-abstract-child-p displayor)
358 ;; For focusing displayors, we can claim this is
359 ;; not unique. Multiple focuses can choose the correct
360 ;; one.
361 (setq answer "Not Unique")
362 ;; If we don't have a focusing displayor, we need to do something
363 ;; graceful. First, see if all the matches have the same name.
364 (let ((allsame t)
365 (firstname (semantic-tag-name
366 (car
367 (semanticdb-find-result-nth matchlist 0)))
368 )
369 (cnt 1)
370 (max (semanticdb-find-result-length matchlist)))
371 (while (and allsame (< cnt max))
372 (if (not (string=
373 firstname
374 (semantic-tag-name
375 (car
376 (semanticdb-find-result-nth matchlist cnt)))))
377 (setq allsame nil))
378 (setq cnt (1+ cnt))
379 )
380 ;; Now we know if they are all the same. If they are, just
381 ;; accept the first, otherwise complain.
382 (if allsame
383 (setq answer (semanticdb-find-result-nth-in-buffer
384 matchlist 0))
385 (setq answer "Not Unique"))
386 ))))
387 ;; No match
388 (t
389 (setq answer "No Match")))
390 )
391 ;; Set it into our completion target.
392 (when (semantic-tag-p answer)
393 (setq semantic-complete-current-matched-tag answer)
394 ;; Make sure it is up to date by clearing it if the user dares
395 ;; to touch the keyboard.
396 (add-hook 'pre-command-hook
397 (lambda () (setq semantic-complete-current-matched-tag nil)))
398 )
399 ;; Return it
400 answer
401 ))
402
403
404;;; Keybindings
405;;
406;; Keys are bound to to perform completion using our mechanisms.
407;; Do that work here.
408(defun semantic-complete-done ()
409 "Accept the current input."
410 (interactive)
411 (let ((ans (semantic-complete-current-match)))
412 (if (stringp ans)
413 (semantic-completion-message (concat " [" ans "]"))
414 (exit-minibuffer)))
415 )
416
417(defun semantic-complete-complete-space ()
418 "Complete the partial input in the minibuffer."
419 (interactive)
420 (semantic-complete-do-completion t))
421
422(defun semantic-complete-complete-tab ()
423 "Complete the partial input in the minibuffer as far as possible."
424 (interactive)
425 (semantic-complete-do-completion))
426
427;;; Completion Functions
428;;
429;; Thees routines are functional entry points to performing completion.
430;;
431(defun semantic-complete-hack-word-boundaries (original new)
432 "Return a string to use for completion.
433ORIGINAL is the text in the minibuffer.
434NEW is the new text to insert into the minibuffer.
435Within the difference bounds of ORIGINAL and NEW, shorten NEW
436to the nearest word boundary, and return that."
437 (save-match-data
438 (let* ((diff (substring new (length original)))
439 (end (string-match "\\>" diff))
440 (start (string-match "\\<" diff)))
441 (cond
442 ((and start (> start 0))
443 ;; If start is greater than 0, include only the new
444 ;; white-space stuff
445 (concat original (substring diff 0 start)))
446 (end
447 (concat original (substring diff 0 end)))
448 (t new)))))
449
450(defun semantic-complete-try-completion (&optional partial)
451 "Try a completion for the current minibuffer.
452If PARTIAL, do partial completion stopping at spaces."
453 (let ((comp (semantic-collector-try-completion
454 semantic-completion-collector-engine
455 (semantic-completion-text))))
456 (cond
457 ((null comp)
458 (semantic-completion-message " [No Match]")
459 (ding)
460 )
461 ((stringp comp)
462 (if (string= (semantic-completion-text) comp)
463 (when partial
464 ;; Minibuffer isn't changing AND the text is not unique.
465 ;; Test for partial completion over a word separator character.
466 ;; If there is one available, use that so that SPC can
467 ;; act like a SPC insert key.
468 (let ((newcomp (semantic-collector-current-whitespace-completion
469 semantic-completion-collector-engine)))
470 (when newcomp
471 (semantic-completion-delete-text)
472 (insert newcomp))
473 ))
474 (when partial
475 (let ((orig (semantic-completion-text)))
476 ;; For partial completion, we stop and step over
477 ;; word boundaries. Use this nifty function to do
478 ;; that calculation for us.
479 (setq comp
480 (semantic-complete-hack-word-boundaries orig comp))))
481 ;; Do the replacement.
482 (semantic-completion-delete-text)
483 (insert comp))
484 )
485 ((and (listp comp) (semantic-tag-p (car comp)))
486 (unless (string= (semantic-completion-text)
487 (semantic-tag-name (car comp)))
488 ;; A fully unique completion was available.
489 (semantic-completion-delete-text)
490 (insert (semantic-tag-name (car comp))))
491 ;; The match is complete
492 (if (= (length comp) 1)
493 (semantic-completion-message " [Complete]")
494 (semantic-completion-message " [Complete, but not unique]"))
495 )
496 (t nil))))
497
498(defun semantic-complete-do-completion (&optional partial inline)
499 "Do a completion for the current minibuffer.
500If PARTIAL, do partial completion stopping at spaces.
501if INLINE, then completion is happening inline in a buffer."
502 (let* ((collector semantic-completion-collector-engine)
503 (displayor semantic-completion-display-engine)
504 (contents (semantic-completion-text))
505 (ans nil))
506
507 (save-excursion
508 (semantic-collector-calculate-completions collector contents partial))
509 (let* ((na (semantic-complete-next-action partial)))
510 (cond
511 ;; We're all done, but only from a very specific
512 ;; area of completion.
513 ((eq na 'done)
514 (semantic-completion-message " [Complete]")
515 (setq ans 'done))
516 ;; Perform completion
517 ((or (eq na 'complete)
518 (eq na 'complete-whitespace))
519 (semantic-complete-try-completion partial)
520 (setq ans 'complete))
521 ;; We need to display the completions.
522 ;; Set the completions into the display engine
523 ((or (eq na 'display) (eq na 'displayend))
524 (semantic-displayor-set-completions
525 displayor
526 (or
527 (and (not (eq na 'displayend))
528 (semantic-collector-current-exact-match collector))
529 (semantic-collector-all-completions collector contents))
530 contents)
531 ;; Ask the displayor to display them.
532 (semantic-displayor-show-request displayor))
533 ((eq na 'scroll)
534 (semantic-displayor-scroll-request displayor)
535 )
536 ((eq na 'focus)
537 (semantic-displayor-focus-next displayor)
538 (semantic-displayor-focus-request displayor)
539 )
540 ((eq na 'empty)
541 (semantic-completion-message " [No Match]"))
542 (t nil)))
543 ans))
544
545
546;;; ------------------------------------------------------------
547;;; INLINE: tag completion harness
548;;
549;; Unlike the minibuffer, there is no mode nor other traditional
550;; means of reading user commands in completion mode. Instead
551;; we use a pre-command-hook to inset in our commands, and to
552;; push ourselves out of this mode on alternate keypresses.
553(defvar semantic-complete-inline-map
554 (let ((km (make-sparse-keymap)))
555 (define-key km "\C-i" 'semantic-complete-inline-TAB)
556 (define-key km "\M-p" 'semantic-complete-inline-up)
557 (define-key km "\M-n" 'semantic-complete-inline-down)
558 (define-key km "\C-m" 'semantic-complete-inline-done)
559 (define-key km "\C-\M-c" 'semantic-complete-inline-exit)
560 (define-key km "\C-g" 'semantic-complete-inline-quit)
561 (define-key km "?"
562 (lambda () (interactive)
563 (describe-variable 'semantic-complete-inline-map)))
564 km)
565 "Keymap used while performing Semantic inline completion.
566\\{semantic-complete-inline-map}")
567
568(defface semantic-complete-inline-face
569 '((((class color) (background dark))
570 (:underline "yellow"))
571 (((class color) (background light))
572 (:underline "brown")))
573 "*Face used to show the region being completed inline.
574The face is used in `semantic-complete-inline-tag-engine'."
575 :group 'semantic-faces)
576
577(defun semantic-complete-inline-text ()
578 "Return the text that is being completed inline.
579Similar to `minibuffer-contents' when completing in the minibuffer."
580 (let ((s (semantic-overlay-start semantic-complete-inline-overlay))
581 (e (semantic-overlay-end semantic-complete-inline-overlay)))
582 (if (= s e)
583 ""
584 (buffer-substring-no-properties s e ))))
585
586(defun semantic-complete-inline-delete-text ()
587 "Delete the text currently being completed in the current buffer."
588 (delete-region
589 (semantic-overlay-start semantic-complete-inline-overlay)
590 (semantic-overlay-end semantic-complete-inline-overlay)))
591
592(defun semantic-complete-inline-done ()
593 "This completion thing is DONE, OR, insert a newline."
594 (interactive)
595 (let* ((displayor semantic-completion-display-engine)
596 (tag (semantic-displayor-current-focus displayor)))
597 (if tag
598 (let ((txt (semantic-completion-text)))
599 (insert (substring (semantic-tag-name tag)
600 (length txt)))
601 (semantic-complete-inline-exit))
602
603 ;; Get whatever binding RET usually has.
604 (let ((fcn
605 (condition-case nil
606 (lookup-key (current-active-maps) (this-command-keys))
607 (error
608 ;; I don't know why, but for some reason the above
609 ;; throws an error sometimes.
610 (lookup-key (current-global-map) (this-command-keys))
611 ))))
612 (when fcn
613 (funcall fcn)))
614 )))
615
616(defun semantic-complete-inline-quit ()
617 "Quit an inline edit."
618 (interactive)
619 (semantic-complete-inline-exit)
620 (keyboard-quit))
621
622(defun semantic-complete-inline-exit ()
623 "Exit inline completion mode."
624 (interactive)
625 ;; Remove this hook FIRST!
626 (remove-hook 'pre-command-hook 'semantic-complete-pre-command-hook)
627
628 (condition-case nil
629 (progn
630 (when semantic-completion-collector-engine
631 (semantic-collector-cleanup semantic-completion-collector-engine))
632 (when semantic-completion-display-engine
633 (semantic-displayor-cleanup semantic-completion-display-engine))
634
635 (when semantic-complete-inline-overlay
636 (let ((wc (semantic-overlay-get semantic-complete-inline-overlay
637 'window-config-start))
638 (buf (semantic-overlay-buffer semantic-complete-inline-overlay))
639 )
640 (semantic-overlay-delete semantic-complete-inline-overlay)
641 (setq semantic-complete-inline-overlay nil)
642 ;; DONT restore the window configuration if we just
643 ;; switched windows!
644 (when (eq buf (current-buffer))
645 (set-window-configuration wc))
646 ))
647
648 (setq semantic-completion-collector-engine nil
649 semantic-completion-display-engine nil))
650 (error nil))
651
652 ;; Remove this hook LAST!!!
653 ;; This will force us back through this function if there was
654 ;; some sort of error above.
655 (remove-hook 'post-command-hook 'semantic-complete-post-command-hook)
656
657 ;;(message "Exiting inline completion.")
658 )
659
660(defun semantic-complete-pre-command-hook ()
661 "Used to redefine what commands are being run while completing.
662When installed as a `pre-command-hook' the special keymap
663`semantic-complete-inline-map' is queried to replace commands normally run.
664Commands which edit what is in the region of interest operate normally.
665Commands which would take us out of the region of interest, or our
666quit hook, will exit this completion mode."
667 (let ((fcn (lookup-key semantic-complete-inline-map
668 (this-command-keys) nil)))
669 (cond ((commandp fcn)
670 (setq this-command fcn))
671 (t nil)))
672 )
673
674(defun semantic-complete-post-command-hook ()
675 "Used to determine if we need to exit inline completion mode.
676If completion mode is active, check to see if we are within
677the bounds of `semantic-complete-inline-overlay', or within
678a reasonable distance."
679 (condition-case nil
680 ;; Exit if something bad happened.
681 (if (not semantic-complete-inline-overlay)
682 (progn
683 ;;(message "Inline Hook installed, but overlay deleted.")
684 (semantic-complete-inline-exit))
685 ;; Exit if commands caused us to exit the area of interest
686 (let ((s (semantic-overlay-start semantic-complete-inline-overlay))
687 (e (semantic-overlay-end semantic-complete-inline-overlay))
688 (b (semantic-overlay-buffer semantic-complete-inline-overlay))
689 (txt nil)
690 )
691 (cond
692 ;; EXIT when we are no longer in a good place.
693 ((or (not (eq b (current-buffer)))
694 (< (point) s)
695 (> (point) e))
696 ;;(message "Exit: %S %S %S" s e (point))
697 (semantic-complete-inline-exit)
698 )
699 ;; Exit if the user typed in a character that is not part
700 ;; of the symbol being completed.
701 ((and (setq txt (semantic-completion-text))
702 (not (string= txt ""))
703 (and (/= (point) s)
704 (save-excursion
705 (forward-char -1)
706 (not (looking-at "\\(\\w\\|\\s_\\)")))))
707 ;;(message "Non symbol character.")
708 (semantic-complete-inline-exit))
709 ((lookup-key semantic-complete-inline-map
710 (this-command-keys) nil)
711 ;; If the last command was one of our completion commands,
712 ;; then do nothing.
713 nil
714 )
715 (t
716 ;; Else, show completions now
717 (semantic-complete-inline-force-display)
718
719 ))))
720 ;; If something goes terribly wrong, clean up after ourselves.
721 (error (semantic-complete-inline-exit))))
722
723(defun semantic-complete-inline-force-display ()
724 "Force the display of whatever the current completions are.
725DO NOT CALL THIS IF THE INLINE COMPLETION ENGINE IS NOT ACTIVE."
726 (condition-case e
727 (save-excursion
728 (let ((collector semantic-completion-collector-engine)
729 (displayor semantic-completion-display-engine)
730 (contents (semantic-completion-text)))
731 (when collector
732 (semantic-collector-calculate-completions
733 collector contents nil)
734 (semantic-displayor-set-completions
735 displayor
736 (semantic-collector-all-completions collector contents)
737 contents)
738 ;; Ask the displayor to display them.
739 (semantic-displayor-show-request displayor))
740 ))
741 (error (message "Bug Showing Completions: %S" e))))
742
743(defun semantic-complete-inline-tag-engine
744 (collector displayor buffer start end)
745 "Perform completion based on semantic tags in a buffer.
746Argument COLLECTOR is an object which can be used to to calculate
747a list of possible hits. See `semantic-completion-collector-engine'
748for details on COLLECTOR.
749Argumeng DISPLAYOR is an object used to display a list of possible
750completions for a given prefix. See`semantic-completion-display-engine'
751for details on DISPLAYOR.
752BUFFER is the buffer in which completion will take place.
753START is a location for the start of the full symbol.
754If the symbol being completed is \"foo.ba\", then START
755is on the \"f\" character.
756END is at the end of the current symbol being completed."
757 ;; Set us up for doing completion
758 (setq semantic-completion-collector-engine collector
759 semantic-completion-display-engine displayor)
760 ;; Create an overlay
761 (setq semantic-complete-inline-overlay
762 (semantic-make-overlay start end buffer nil t))
763 (semantic-overlay-put semantic-complete-inline-overlay
764 'face
765 'semantic-complete-inline-face)
766 (semantic-overlay-put semantic-complete-inline-overlay
767 'window-config-start
768 (current-window-configuration))
769 ;; Install our command hooks
770 (add-hook 'pre-command-hook 'semantic-complete-pre-command-hook)
771 (add-hook 'post-command-hook 'semantic-complete-post-command-hook)
772 ;; Go!
773 (semantic-complete-inline-force-display)
774 )
775
776;;; Inline Completion Keymap Functions
777;;
778(defun semantic-complete-inline-TAB ()
779 "Perform inline completion."
780 (interactive)
781 (let ((cmpl (semantic-complete-do-completion nil t)))
782 (cond
783 ((eq cmpl 'complete)
784 (semantic-complete-inline-force-display))
785 ((eq cmpl 'done)
786 (semantic-complete-inline-done))
787 ))
788 )
789
790(defun semantic-complete-inline-down()
791 "Focus forwards through the displayor."
792 (interactive)
793 (let ((displayor semantic-completion-display-engine))
794 (semantic-displayor-focus-next displayor)
795 (semantic-displayor-focus-request displayor)
796 ))
797
798(defun semantic-complete-inline-up ()
799 "Focus backwards through the displayor."
800 (interactive)
801 (let ((displayor semantic-completion-display-engine))
802 (semantic-displayor-focus-previous displayor)
803 (semantic-displayor-focus-request displayor)
804 ))
805
806
807;;; ------------------------------------------------------------
808;;; Interactions between collection and displaying
809;;
810;; Functional routines used to help collectors communicate with
811;; the current displayor, or for the previous section.
812
813(defun semantic-complete-next-action (partial)
814 "Determine what the next completion action should be.
815PARTIAL is non-nil if we are doing partial completion.
816First, the collector can determine if we should perform a completion or not.
817If there is nothing to complete, then the displayor determines if we are
818to show a completion list, scroll, or perhaps do a focus (if it is capable.)
819Expected return values are:
820 done -> We have a singular match
821 empty -> There are no matches to the current text
822 complete -> Perform a completion action
823 complete-whitespace -> Complete next whitespace type character.
824 display -> Show the list of completions
825 scroll -> The completions have been shown, and the user keeps hitting
826 the complete button. If possible, scroll the completions
827 focus -> The displayor knows how to shift focus among possible completions.
828 Let it do that.
829 displayend -> Whatever options the displayor had for repeating options, there
830 are none left. Try something new."
831 (let ((ans1 (semantic-collector-next-action
832 semantic-completion-collector-engine
833 partial))
834 (ans2 (semantic-displayor-next-action
835 semantic-completion-display-engine))
836 )
837 (cond
838 ;; No collector answer, use displayor answer.
839 ((not ans1)
840 ans2)
841 ;; Displayor selection of 'scroll, 'display, or 'focus trumps
842 ;; 'done
843 ((and (eq ans1 'done) ans2)
844 ans2)
845 ;; Use ans1 when we have it.
846 (t
847 ans1))))
848
849
850
851;;; ------------------------------------------------------------
852;;; Collection Engines
853;;
854;; Collection engines can scan tags from the current environment and
855;; provide lists of possible completions.
856;;
857;; General features of the abstract collector:
858;; * Cache completion lists between uses
859;; * Cache itself per buffer. Handle reparse hooks
860;;
861;; Key Interface Functions to implement:
862;; * semantic-collector-next-action
863;; * semantic-collector-calculate-completions
864;; * semantic-collector-try-completion
865;; * semantic-collector-all-completions
866
867(defvar semantic-collector-per-buffer-list nil
868 "List of collectors active in this buffer.")
869(make-variable-buffer-local 'semantic-collector-per-buffer-list)
870
871(defvar semantic-collector-list nil
872 "List of global collectors active this session.")
873
874(defclass semantic-collector-abstract ()
875 ((buffer :initarg :buffer
876 :type buffer
877 :documentation "Originating buffer for this collector.
878Some collectors use a given buffer as a starting place while looking up
879tags.")
880 (cache :initform nil
881 :type (or null semanticdb-find-result-with-nil)
882 :documentation "Cache of tags.
883These tags are re-used during a completion session.
884Sometimes these tags are cached between completion sessions.")
885 (last-all-completions :initarg nil
886 :type semanticdb-find-result-with-nil
887 :documentation "Last result of `all-completions'.
888This result can be used for refined completions as `last-prefix' gets
889closer to a specific result.")
890 (last-prefix :type string
891 :protection :protected
892 :documentation "The last queried prefix.
893This prefix can be used to cache intermediate completion offers.
894making the action of homing in on a token faster.")
895 (last-completion :type (or null string)
896 :documentation "The last calculated completion.
897This completion is calculated and saved for future use.")
898 (last-whitespace-completion :type (or null string)
899 :documentation "The last whitespace completion.
900For partial completion, SPC will disabiguate over whitespace type
901characters. This is the last calculated version.")
902 (current-exact-match :type list
903 :protection :protected
904 :documentation "The list of matched tags.
905When tokens are matched, they are added to this list.")
906 )
907 "Root class for completion engines.
908The baseclass provides basic functionality for interacting with
909a completion displayor object, and tracking the current progress
910of a completion."
911 :abstract t)
912
913(defmethod semantic-collector-cleanup ((obj semantic-collector-abstract))
914 "Clean up any mess this collector may have."
915 nil)
916
917(defmethod semantic-collector-next-action
918 ((obj semantic-collector-abstract) partial)
919 "What should we do next? OBJ can predict a next good action.
920PARTIAL indicates if we are doing a partial completion."
921 (if (and (slot-boundp obj 'last-completion)
922 (string= (semantic-completion-text) (oref obj last-completion)))
923 (let* ((cem (semantic-collector-current-exact-match obj))
924 (cemlen (semanticdb-find-result-length cem))
925 (cac (semantic-collector-all-completions
926 obj (semantic-completion-text)))
927 (caclen (semanticdb-find-result-length cac)))
928 (cond ((and cem (= cemlen 1)
929 cac (> caclen 1)
930 (eq last-command this-command))
931 ;; Defer to the displayor...
932 nil)
933 ((and cem (= cemlen 1))
934 'done)
935 ((and (not cem) (not cac))
936 'empty)
937 ((and partial (semantic-collector-try-completion-whitespace
938 obj (semantic-completion-text)))
939 'complete-whitespace)))
940 'complete))
941
942(defmethod semantic-collector-last-prefix= ((obj semantic-collector-abstract)
943 last-prefix)
944 "Return non-nil if OBJ's prefix matches PREFIX."
945 (and (slot-boundp obj 'last-prefix)
946 (string= (oref obj last-prefix) last-prefix)))
947
948(defmethod semantic-collector-get-cache ((obj semantic-collector-abstract))
949 "Get the raw cache of tags for completion.
950Calculate the cache if there isn't one."
951 (or (oref obj cache)
952 (semantic-collector-calculate-cache obj)))
953
954(defmethod semantic-collector-calculate-completions-raw
955 ((obj semantic-collector-abstract) prefix completionlist)
956 "Calculate the completions for prefix from completionlist.
957Output must be in semanticdb Find result format."
958 ;; Must output in semanticdb format
959 (let ((table (save-excursion
960 (set-buffer (oref obj buffer))
961 semanticdb-current-table))
962 (result (semantic-find-tags-for-completion
963 prefix
964 ;; To do this kind of search with a pre-built completion
965 ;; list, we need to strip it first.
966 (semanticdb-strip-find-results completionlist)))
967 )
968 (if result
969 (list (cons table result)))))
970
971(defmethod semantic-collector-calculate-completions
972 ((obj semantic-collector-abstract) prefix partial)
973 "Calculate completions for prefix as setup for other queries."
974 (let* ((case-fold-search semantic-case-fold)
975 (same-prefix-p (semantic-collector-last-prefix= obj prefix))
976 (completionlist
977 (if (or same-prefix-p
978 (and (slot-boundp obj 'last-prefix)
979 (eq (compare-strings (oref obj last-prefix) 0 nil
980 prefix 0 (length prefix))
981 t)))
982 ;; New prefix is subset of old prefix
983 (oref obj last-all-completions)
984 (semantic-collector-get-cache obj)))
985 ;; Get the result
986 (answer (if same-prefix-p
987 completionlist
988 (semantic-collector-calculate-completions-raw
989 obj prefix completionlist))
990 )
991 (completion nil)
992 (complete-not-uniq nil)
993 )
994 ;;(semanticdb-find-result-test answer)
995 (when (not same-prefix-p)
996 ;; Save results if it is interesting and beneficial
997 (oset obj last-prefix prefix)
998 (oset obj last-all-completions answer))
999 ;; Now calculate the completion.
1000 (setq completion (try-completion
1001 prefix
1002 (semanticdb-strip-find-results answer)))
1003 (oset obj last-whitespace-completion nil)
1004 (oset obj current-exact-match nil)
1005 ;; Only do this if a completion was found. Letting a nil in
1006 ;; could cause a full semanticdb search by accident.
1007 (when completion
1008 (oset obj last-completion
1009 (cond
1010 ;; Unique match in AC. Last completion is a match.
1011 ;; Also set the current-exact-match.
1012 ((eq completion t)
1013 (oset obj current-exact-match answer)
1014 prefix)
1015 ;; It may be complete (a symbol) but still not unique.
1016 ;; We can capture a match
1017 ((setq complete-not-uniq
1018 (semanticdb-find-tags-by-name
1019 prefix
1020 answer))
1021 (oset obj current-exact-match
1022 complete-not-uniq)
1023 prefix
1024 )
1025 ;; Non unique match, return the string that handles
1026 ;; completion
1027 (t (or completion prefix))
1028 )))
1029 ))
1030
1031(defmethod semantic-collector-try-completion-whitespace
1032 ((obj semantic-collector-abstract) prefix)
1033 "For OBJ, do whatepsace completion based on PREFIX.
1034This implies that if there are two completions, one matching
1035the test \"preifx\\>\", and one not, the one matching the full
1036word version of PREFIX will be chosen, and that text returned.
1037This function requires that `semantic-collector-calculate-completions'
1038has been run first."
1039 (let* ((ac (semantic-collector-all-completions obj prefix))
1040 (matchme (concat "^" prefix "\\>"))
1041 (compare (semanticdb-find-tags-by-name-regexp matchme ac))
1042 (numtag (semanticdb-find-result-length compare))
1043 )
1044 (if compare
1045 (let* ((idx 0)
1046 (cutlen (1+ (length prefix)))
1047 (twws (semanticdb-find-result-nth compare idx)))
1048 ;; Is our tag with whitespace a match that has whitespace
1049 ;; after it, or just an already complete symbol?
1050 (while (and (< idx numtag)
1051 (< (length (semantic-tag-name (car twws))) cutlen))
1052 (setq idx (1+ idx)
1053 twws (semanticdb-find-result-nth compare idx)))
1054 (when (and twws (car-safe twws))
1055 ;; If COMPARE has succeeded, then we should take the very
1056 ;; first match, and extend prefix by one character.
1057 (oset obj last-whitespace-completion
1058 (substring (semantic-tag-name (car twws))
1059 0 cutlen))))
1060 )))
1061
1062
1063(defmethod semantic-collector-current-exact-match ((obj semantic-collector-abstract))
1064 "Return the active valid MATCH from the semantic collector.
1065For now, just return the first element from our list of available
1066matches. For semanticdb based results, make sure the file is loaded
1067into a buffer."
1068 (when (slot-boundp obj 'current-exact-match)
1069 (oref obj current-exact-match)))
1070
1071(defmethod semantic-collector-current-whitespace-completion ((obj semantic-collector-abstract))
1072 "Return the active whitespace completion value."
1073 (when (slot-boundp obj 'last-whitespace-completion)
1074 (oref obj last-whitespace-completion)))
1075
1076(defmethod semantic-collector-get-match ((obj semantic-collector-abstract))
1077 "Return the active valid MATCH from the semantic collector.
1078For now, just return the first element from our list of available
1079matches. For semanticdb based results, make sure the file is loaded
1080into a buffer."
1081 (when (slot-boundp obj 'current-exact-match)
1082 (semanticdb-find-result-nth-in-buffer (oref obj current-exact-match) 0)))
1083
1084(defmethod semantic-collector-all-completions
1085 ((obj semantic-collector-abstract) prefix)
1086 "For OBJ, retrieve all completions matching PREFIX.
1087The returned list consists of all the tags currently
1088matching PREFIX."
1089 (when (slot-boundp obj 'last-all-completions)
1090 (oref obj last-all-completions)))
1091
1092(defmethod semantic-collector-try-completion
1093 ((obj semantic-collector-abstract) prefix)
1094 "For OBJ, attempt to match PREFIX.
1095See `try-completion' for details on how this works.
1096Return nil for no match.
1097Return a string for a partial match.
1098For a unique match of PREFIX, return the list of all tags
1099with that name."
1100 (if (slot-boundp obj 'last-completion)
1101 (oref obj last-completion)))
1102
1103(defmethod semantic-collector-calculate-cache
1104 ((obj semantic-collector-abstract))
1105 "Calculate the completion cache for OBJ."
1106 nil
1107 )
1108
1109(defmethod semantic-collector-flush ((this semantic-collector-abstract))
1110 "Flush THIS collector object, clearing any caches and prefix."
1111 (oset this cache nil)
1112 (slot-makeunbound this 'last-prefix)
1113 (slot-makeunbound this 'last-completion)
1114 (slot-makeunbound this 'last-all-completions)
1115 (slot-makeunbound this 'current-exact-match)
1116 )
1117
1118;;; PER BUFFER
1119;;
1120(defclass semantic-collector-buffer-abstract (semantic-collector-abstract)
1121 ()
1122 "Root class for per-buffer completion engines.
1123These collectors track themselves on a per-buffer basis."
1124 :abstract t)
1125
1126(defmethod constructor :STATIC ((this semantic-collector-buffer-abstract)
1127 newname &rest fields)
1128 "Reuse previously created objects of this type in buffer."
1129 (let ((old nil)
1130 (bl semantic-collector-per-buffer-list))
1131 (while (and bl (null old))
1132 (if (eq (object-class (car bl)) this)
1133 (setq old (car bl))))
1134 (unless old
1135 (let ((new (call-next-method)))
1136 (add-to-list 'semantic-collector-per-buffer-list new)
1137 (setq old new)))
1138 (slot-makeunbound old 'last-completion)
1139 (slot-makeunbound old 'last-prefix)
1140 (slot-makeunbound old 'current-exact-match)
1141 old))
1142
1143;; Buffer specific collectors should flush themselves
1144(defun semantic-collector-buffer-flush (newcache)
1145 "Flush all buffer collector objects.
1146NEWCACHE is the new tag table, but we ignore it."
1147 (condition-case nil
1148 (let ((l semantic-collector-per-buffer-list))
1149 (while l
1150 (if (car l) (semantic-collector-flush (car l)))
1151 (setq l (cdr l))))
1152 (error nil)))
1153
1154(add-hook 'semantic-after-toplevel-cache-change-hook
1155 'semantic-collector-buffer-flush)
1156
1157;;; DEEP BUFFER SPECIFIC COMPLETION
1158;;
1159(defclass semantic-collector-buffer-deep
1160 (semantic-collector-buffer-abstract)
1161 ()
1162 "Completion engine for tags in the current buffer.
1163When searching for a tag, uses semantic deep searche functions.
1164Basics search only in the current buffer.")
1165
1166(defmethod semantic-collector-calculate-cache
1167 ((obj semantic-collector-buffer-deep))
1168 "Calculate the completion cache for OBJ.
1169Uses `semantic-flatten-tags-table'"
1170 (oset obj cache
1171 ;; Must create it in SEMANTICDB find format.
1172 ;; ( ( DBTABLE TAG TAG ... ) ... )
1173 (list
1174 (cons semanticdb-current-table
1175 (semantic-flatten-tags-table (oref obj buffer))))))
1176
1177;;; PROJECT SPECIFIC COMPLETION
1178;;
1179(defclass semantic-collector-project-abstract (semantic-collector-abstract)
1180 ((path :initarg :path
1181 :initform nil
1182 :documentation "List of database tables to search.
1183At creation time, it can be anything accepted by
1184`semanticdb-find-translate-path' as a PATH argument.")
1185 )
1186 "Root class for project wide completion engines.
1187Uses semanticdb for searching all tags in the current project."
1188 :abstract t)
1189
1190;;; Project Search
1191(defclass semantic-collector-project (semantic-collector-project-abstract)
1192 ()
1193 "Completion engine for tags in a project.")
1194
1195
1196(defmethod semantic-collector-calculate-completions-raw
1197 ((obj semantic-collector-project) prefix completionlist)
1198 "Calculate the completions for prefix from completionlist."
1199 (semanticdb-find-tags-for-completion prefix (oref obj path)))
1200
1201;;; Brutish Project search
1202(defclass semantic-collector-project-brutish (semantic-collector-project-abstract)
1203 ()
1204 "Completion engine for tags in a project.")
1205
1206(defmethod semantic-collector-calculate-completions-raw
1207 ((obj semantic-collector-project-brutish) prefix completionlist)
1208 "Calculate the completions for prefix from completionlist."
1209 (semanticdb-brute-deep-find-tags-for-completion prefix (oref obj path)))
1210
1211(defclass semantic-collector-analyze-completions (semantic-collector-abstract)
1212 ((context :initarg :context
1213 :type semantic-analyze-context
1214 :documentation "An analysis context.
1215Specifies some context location from whence completion lists will be drawn."
1216 )
1217 (first-pass-completions :type list
1218 :documentation "List of valid completion tags.
1219This list of tags is generated when completion starts. All searches
1220derive from this list.")
1221 )
1222 "Completion engine that uses the context analyzer to provide options.
1223The only options available for completion are those which can be logically
1224inserted into the current context.")
1225
1226(defmethod semantic-collector-calculate-completions-raw
1227 ((obj semantic-collector-analyze-completions) prefix completionlist)
1228 "calculate the completions for prefix from completionlist."
1229 ;; if there are no completions yet, calculate them.
1230 (if (not (slot-boundp obj 'first-pass-completions))
1231 (oset obj first-pass-completions
1232 (semantic-analyze-possible-completions (oref obj context))))
1233 ;; search our cached completion list. make it look like a semanticdb
1234 ;; results type.
1235 (list (cons (save-excursion
1236 (set-buffer (oref (oref obj context) buffer))
1237 semanticdb-current-table)
1238 (semantic-find-tags-for-completion
1239 prefix
1240 (oref obj first-pass-completions)))))
1241
1242
1243;;; ------------------------------------------------------------
1244;;; Tag List Display Engines
1245;;
1246;; A typical displayor accepts a pre-determined list of completions
1247;; generated by a collector. This format is in semanticdb search
1248;; form. This vaguely standard form is a bit challenging to navigate
1249;; because the tags do not contain buffer info, but the file assocated
1250;; with the tags preceed the tag in the list.
1251;;
1252;; Basic displayors don't care, and can strip the results.
1253;; Advanced highlighting displayors need to know when they need
1254;; to load a file so that the tag in question can be highlighted.
1255;;
1256;; Key interface methods to a displayor are:
1257;; * semantic-displayor-next-action
1258;; * semantic-displayor-set-completions
1259;; * semantic-displayor-current-focus
1260;; * semantic-displayor-show-request
1261;; * semantic-displayor-scroll-request
1262;; * semantic-displayor-focus-request
1263
1264(defclass semantic-displayor-abstract ()
1265 ((table :type (or null semanticdb-find-result-with-nil)
1266 :initform nil
1267 :protection :protected
1268 :documentation "List of tags this displayor is showing.")
1269 (last-prefix :type string
1270 :protection :protected
1271 :documentation "Prefix associated with slot `table'")
1272 )
1273 "Abstract displayor baseclass.
1274Manages the display of some number of tags.
1275Provides the basics for a displayor, including interacting with
1276a collector, and tracking tables of completion to display."
1277 :abstract t)
1278
1279(defmethod semantic-displayor-cleanup ((obj semantic-displayor-abstract))
1280 "Clean up any mess this displayor may have."
1281 nil)
1282
1283(defmethod semantic-displayor-next-action ((obj semantic-displayor-abstract))
1284 "The next action to take on the minibuffer related to display."
1285 (if (and (slot-boundp obj 'last-prefix)
1286 (string= (oref obj last-prefix) (semantic-completion-text))
1287 (eq last-command this-command))
1288 'scroll
1289 'display))
1290
1291(defmethod semantic-displayor-set-completions ((obj semantic-displayor-abstract)
1292 table prefix)
1293 "Set the list of tags to be completed over to TABLE."
1294 (oset obj table table)
1295 (oset obj last-prefix prefix))
1296
1297(defmethod semantic-displayor-show-request ((obj semantic-displayor-abstract))
1298 "A request to show the current tags table."
1299 (ding))
1300
1301(defmethod semantic-displayor-focus-request ((obj semantic-displayor-abstract))
1302 "A request to for the displayor to focus on some tag option."
1303 (ding))
1304
1305(defmethod semantic-displayor-scroll-request ((obj semantic-displayor-abstract))
1306 "A request to for the displayor to scroll the completion list (if needed)."
1307 (scroll-other-window))
1308
1309(defmethod semantic-displayor-focus-previous ((obj semantic-displayor-abstract))
1310 "Set the current focus to the previous item."
1311 nil)
1312
1313(defmethod semantic-displayor-focus-next ((obj semantic-displayor-abstract))
1314 "Set the current focus to the next item."
1315 nil)
1316
1317(defmethod semantic-displayor-current-focus ((obj semantic-displayor-abstract))
1318 "Return a single tag currently in focus.
1319This object type doesn't do focus, so will never have a focus object."
1320 nil)
1321
1322;; Traditional displayor
1323(defcustom semantic-completion-displayor-format-tag-function
1324 #'semantic-format-tag-name
1325 "*A Tag format function to use when showing completions."
1326 :group 'semantic
1327 :type semantic-format-tag-custom-list)
1328
1329(defclass semantic-displayor-traditional (semantic-displayor-abstract)
1330 ()
1331 "Display options in *Completions* buffer.
1332Traditional display mechanism for a list of possible completions.
1333Completions are showin in a new buffer and listed with the ability
1334to click on the items to aid in completion.")
1335
1336(defmethod semantic-displayor-show-request ((obj semantic-displayor-traditional))
1337 "A request to show the current tags table."
1338
1339 ;; NOTE TO SELF. Find the character to type next, and emphesize it.
1340
1341 (with-output-to-temp-buffer "*Completions*"
1342 (display-completion-list
1343 (mapcar semantic-completion-displayor-format-tag-function
1344 (semanticdb-strip-find-results (oref obj table))))
1345 )
1346 )
1347
1348;;; Abstract baseclass for any displayor which supports focus
1349(defclass semantic-displayor-focus-abstract (semantic-displayor-abstract)
1350 ((focus :type number
1351 :protection :protected
1352 :documentation "A tag index from `table' which has focus.
1353Multiple calls to the display function can choose to focus on a
1354given tag, by highlighting its location.")
1355 (find-file-focus
1356 :allocation :class
1357 :initform nil
1358 :documentation
1359 "Non-nil if focusing requires a tag's buffer be in memory.")
1360 )
1361 "Abstract displayor supporting `focus'.
1362A displayor which has the ability to focus in on one tag.
1363Focusing is a way of differentiationg between multiple tags
1364which have the same name."
1365 :abstract t)
1366
1367(defmethod semantic-displayor-next-action ((obj semantic-displayor-focus-abstract))
1368 "The next action to take on the minibuffer related to display."
1369 (if (and (slot-boundp obj 'last-prefix)
1370 (string= (oref obj last-prefix) (semantic-completion-text))
1371 (eq last-command this-command))
1372 (if (and
1373 (slot-boundp obj 'focus)
1374 (slot-boundp obj 'table)
1375 (<= (semanticdb-find-result-length (oref obj table))
1376 (1+ (oref obj focus))))
1377 ;; We are at the end of the focus road.
1378 'displayend
1379 ;; Focus on some item.
1380 'focus)
1381 'display))
1382
1383(defmethod semantic-displayor-set-completions ((obj semantic-displayor-focus-abstract)
1384 table prefix)
1385 "Set the list of tags to be completed over to TABLE."
1386 (call-next-method)
1387 (slot-makeunbound obj 'focus))
1388
1389(defmethod semantic-displayor-focus-previous ((obj semantic-displayor-focus-abstract))
1390 "Set the current focus to the previous item.
1391Not meaningful return value."
1392 (when (and (slot-boundp obj 'table) (oref obj table))
1393 (with-slots (table) obj
1394 (if (or (not (slot-boundp obj 'focus))
1395 (<= (oref obj focus) 0))
1396 (oset obj focus (1- (semanticdb-find-result-length table)))
1397 (oset obj focus (1- (oref obj focus)))
1398 )
1399 )))
1400
1401(defmethod semantic-displayor-focus-next ((obj semantic-displayor-focus-abstract))
1402 "Set the current focus to the next item.
1403Not meaningful return value."
1404 (when (and (slot-boundp obj 'table) (oref obj table))
1405 (with-slots (table) obj
1406 (if (not (slot-boundp obj 'focus))
1407 (oset obj focus 0)
1408 (oset obj focus (1+ (oref obj focus)))
1409 )
1410 (if (<= (semanticdb-find-result-length table) (oref obj focus))
1411 (oset obj focus 0))
1412 )))
1413
1414(defmethod semantic-displayor-focus-tag ((obj semantic-displayor-focus-abstract))
1415 "Return the next tag OBJ should focus on."
1416 (when (and (slot-boundp obj 'table) (oref obj table))
1417 (with-slots (table) obj
1418 (semanticdb-find-result-nth table (oref obj focus)))))
1419
1420(defmethod semantic-displayor-current-focus ((obj semantic-displayor-focus-abstract))
1421 "Return the tag currently in focus, or call parent method."
1422 (if (and (slot-boundp obj 'focus)
1423 (slot-boundp obj 'table)
1424 ;; Only return the current focus IFF the minibuffer reflects
1425 ;; the list this focus was derived from.
1426 (slot-boundp obj 'last-prefix)
1427 (string= (semantic-completion-text) (oref obj last-prefix))
1428 )
1429 ;; We need to focus
1430 (if (oref obj find-file-focus)
1431 (semanticdb-find-result-nth-in-buffer (oref obj table) (oref obj focus))
1432 ;; result-nth returns a cons with car being the tag, and cdr the
1433 ;; database.
1434 (car (semanticdb-find-result-nth (oref obj table) (oref obj focus))))
1435 ;; Do whatever
1436 (call-next-method)))
1437
1438;;; Simple displayor which performs traditional display completion,
1439;; and also focuses with highlighting.
1440(defclass semantic-displayor-traditional-with-focus-highlight
1441 (semantic-displayor-focus-abstract semantic-displayor-traditional)
1442 ((find-file-focus :initform t))
1443 "Display completions in *Completions* buffer, with focus highlight.
1444A traditional displayor which can focus on a tag by showing it.
1445Same as `semantic-displayor-traditional', but with selection between
1446multiple tags with the same name done by 'focusing' on the source
1447location of the different tags to differentiate them.")
1448
1449(defmethod semantic-displayor-focus-request
1450 ((obj semantic-displayor-traditional-with-focus-highlight))
1451 "Focus in on possible tag completions.
1452Focus is performed by cycling through the tags and highlighting
1453one in the source buffer."
1454 (let* ((tablelength (semanticdb-find-result-length (oref obj table)))
1455 (focus (semantic-displayor-focus-tag obj))
1456 ;; Raw tag info.
1457 (rtag (car focus))
1458 (rtable (cdr focus))
1459 ;; Normalize
1460 (nt (semanticdb-normalize-one-tag rtable rtag))
1461 (tag (cdr nt))
1462 (table (car nt))
1463 )
1464 ;; If we fail to normalize, resete.
1465 (when (not tag) (setq table rtable tag rtag))
1466 ;; Do the focus.
1467 (let ((buf (or (semantic-tag-buffer tag)
1468 (and table (semanticdb-get-buffer table)))))
1469 ;; If no buffer is provided, then we can make up a summary buffer.
1470 (when (not buf)
1471 (save-excursion
1472 (set-buffer (get-buffer-create "*Completion Focus*"))
1473 (erase-buffer)
1474 (insert "Focus on tag: \n")
1475 (insert (semantic-format-tag-summarize tag nil t) "\n\n")
1476 (when table
1477 (insert "From table: \n")
1478 (insert (object-name table) "\n\n"))
1479 (when buf
1480 (insert "In buffer: \n\n")
1481 (insert (format "%S" buf)))
1482 (setq buf (current-buffer))))
1483 ;; Show the tag in the buffer.
1484 (if (get-buffer-window buf)
1485 (select-window (get-buffer-window buf))
1486 (switch-to-buffer-other-window buf t)
1487 (select-window (get-buffer-window buf)))
1488 ;; Now do some positioning
1489 (unwind-protect
1490 (if (semantic-tag-with-position-p tag)
1491 ;; Full tag positional information available
1492 (progn
1493 (goto-char (semantic-tag-start tag))
1494 ;; This avoids a dangerous problem if we just loaded a tag
1495 ;; from a file, but the original position was not updated
1496 ;; in the TAG variable we are currently using.
1497 (semantic-momentary-highlight-tag (semantic-current-tag))
1498 ))
1499 (select-window (minibuffer-window)))
1500 ;; Calculate text difference between contents and the focus item.
1501 (let* ((mbc (semantic-completion-text))
1502 (ftn (semantic-tag-name tag))
1503 (diff (substring ftn (length mbc))))
1504 (semantic-completion-message
1505 (format "%s [%d of %d matches]" diff (1+ (oref obj focus)) tablelength)))
1506 )))
1507
1508
1509;;; Tooltip completion lister
1510;;
1511;; Written and contributed by Masatake YAMATO <jet@gyve.org>
1512;;
1513;; Modified by Eric Ludlam for
1514;; * Safe compatibility for tooltip free systems.
1515;; * Don't use 'avoid package for tooltip positioning.
1516
1517(defclass semantic-displayor-tooltip (semantic-displayor-traditional)
1518 ((max-tags :type integer
1519 :initarg :max-tags
1520 :initform 5
1521 :custom integer
1522 :documentation
1523 "Max number of tags displayed on tooltip at once.
1524If `force-show' is 1, this value is ignored with typing tab or space twice continuously.
1525if `force-show' is 0, this value is always ignored.")
1526 (force-show :type integer
1527 :initarg :force-show
1528 :initform 1
1529 :custom (choice (const
1530 :tag "Show when double typing"
1531 1)
1532 (const
1533 :tag "Show always"
1534 0)
1535 (const
1536 :tag "Show if the number of tags is less than `max-tags'."
1537 -1))
1538 :documentation
1539 "Control the behavior of the number of tags is greater than `max-tags'.
1540-1 means tags are never shown.
15410 means the tags are always shown.
15421 means tags are shown if space or tab is typed twice continuously.")
1543 (typing-count :type integer
1544 :initform 0
1545 :documentation
1546 "Counter holding how many times the user types space or tab continuously before showing tags.")
1547 (shown :type boolean
1548 :initform nil
1549 :documentation
1550 "Flag representing whether tags is shown once or not.")
1551 )
1552 "Display completions options in a tooltip.
1553Display mechanism using tooltip for a list of possible completions.")
1554
1555(defmethod initialize-instance :AFTER ((obj semantic-displayor-tooltip) &rest args)
1556 "Make sure we have tooltips required."
1557 (condition-case nil
1558 (require 'tooltip)
1559 (error nil))
1560 )
1561
1562(defmethod semantic-displayor-show-request ((obj semantic-displayor-tooltip))
1563 "A request to show the current tags table."
1564 (if (or (not (featurep 'tooltip)) (not tooltip-mode))
1565 ;; If we cannot use tooltips, then go to the normal mode with
1566 ;; a traditional completion buffer.
1567 (call-next-method)
1568 (let* ((tablelong (semanticdb-strip-find-results (oref obj table)))
1569 (table (semantic-unique-tag-table-by-name tablelong))
1570 (l (mapcar semantic-completion-displayor-format-tag-function table))
1571 (ll (length l))
1572 (typing-count (oref obj typing-count))
1573 (force-show (oref obj force-show))
1574 (matchtxt (semantic-completion-text))
1575 msg)
1576 (if (or (oref obj shown)
1577 (< ll (oref obj max-tags))
1578 (and (<= 0 force-show)
1579 (< (1- force-show) typing-count)))
1580 (progn
1581 (oset obj typing-count 0)
1582 (oset obj shown t)
1583 (if (eq 1 ll)
1584 ;; We Have only one possible match. There could be two cases.
1585 ;; 1) input text != single match.
1586 ;; --> Show it!
1587 ;; 2) input text == single match.
1588 ;; --> Complain about it, but still show the match.
1589 (if (string= matchtxt (semantic-tag-name (car table)))
1590 (setq msg (concat "[COMPLETE]\n" (car l)))
1591 (setq msg (car l)))
1592 ;; Create the long message.
1593 (setq msg (mapconcat 'identity l "\n"))
1594 ;; If there is nothing, say so!
1595 (if (eq 0 (length msg))
1596 (setq msg "[NO MATCH]")))
1597 (semantic-displayor-tooltip-show msg))
1598 ;; The typing count determines if the user REALLY REALLY
1599 ;; wanted to show that much stuff. Only increment
1600 ;; if the current command is a completion command.
1601 (if (and (stringp (this-command-keys))
1602 (string= (this-command-keys) "\C-i"))
1603 (oset obj typing-count (1+ typing-count)))
1604 ;; At this point, we know we have too many items.
1605 ;; Lets be brave, and truncate l
1606 (setcdr (nthcdr (oref obj max-tags) l) nil)
1607 (setq msg (mapconcat 'identity l "\n"))
1608 (cond
1609 ((= force-show -1)
1610 (semantic-displayor-tooltip-show (concat msg "\n...")))
1611 ((= force-show 1)
1612 (semantic-displayor-tooltip-show (concat msg "\n(TAB for more)")))
1613 )))))
1614
1615;;; Compatibility
1616;;
1617(eval-and-compile
1618 (if (fboundp 'window-inside-edges)
1619 ;; Emacs devel.
1620 (defalias 'semantic-displayor-window-edges
1621 'window-inside-edges)
1622 ;; Emacs 21
1623 (defalias 'semantic-displayor-window-edges
1624 'window-edges)
1625 ))
1626
1627(defun semantic-displayor-point-position ()
1628 "Return the location of POINT as positioned on the selected frame.
1629Return a cons cell (X . Y)"
1630 (let* ((frame (selected-frame))
1631 (left (frame-parameter frame 'left))
1632 (top (frame-parameter frame 'top))
1633 (point-pix-pos (posn-x-y (posn-at-point)))
1634 (edges (window-inside-pixel-edges (selected-window))))
1635 (cons (+ (car point-pix-pos) (car edges) left)
1636 (+ (cdr point-pix-pos) (cadr edges) top))))
1637
1638
1639(defun semantic-displayor-tooltip-show (text)
1640 "Display a tooltip with TEXT near cursor."
1641 (let ((point-pix-pos (semantic-displayor-point-position))
1642 (tooltip-frame-parameters
1643 (append tooltip-frame-parameters nil)))
1644 (push
1645 (cons 'left (+ (car point-pix-pos) (frame-char-width)))
1646 tooltip-frame-parameters)
1647 (push
1648 (cons 'top (+ (cdr point-pix-pos) (frame-char-height)))
1649 tooltip-frame-parameters)
1650 (tooltip-show text)))
1651
1652(defmethod semantic-displayor-scroll-request ((obj semantic-displayor-tooltip))
1653 "A request to for the displayor to scroll the completion list (if needed)."
1654 ;; Do scrolling in the tooltip.
1655 (oset obj max-tags 30)
1656 (semantic-displayor-show-request obj)
1657 )
1658
1659;; End code contributed by Masatake YAMATO <jet@gyve.org>
1660
1661
1662;;; Ghost Text displayor
1663;;
1664(defclass semantic-displayor-ghost (semantic-displayor-focus-abstract)
1665
1666 ((ghostoverlay :type overlay
1667 :documentation
1668 "The overlay the ghost text is displayed in.")
1669 (first-show :initform t
1670 :documentation
1671 "Non nil if we have not seen our first show request.")
1672 )
1673 "Cycle completions inline with ghost text.
1674Completion displayor using ghost chars after point for focus options.
1675Whichever completion is currently in focus will be displayed as ghost
1676text using overlay options.")
1677
1678(defmethod semantic-displayor-next-action ((obj semantic-displayor-ghost))
1679 "The next action to take on the inline completion related to display."
1680 (let ((ans (call-next-method))
1681 (table (when (slot-boundp obj 'table)
1682 (oref obj table))))
1683 (if (and (eq ans 'displayend)
1684 table
1685 (= (semanticdb-find-result-length table) 1)
1686 )
1687 nil
1688 ans)))
1689
1690(defmethod semantic-displayor-cleanup ((obj semantic-displayor-ghost))
1691 "Clean up any mess this displayor may have."
1692 (when (slot-boundp obj 'ghostoverlay)
1693 (semantic-overlay-delete (oref obj ghostoverlay)))
1694 )
1695
1696(defmethod semantic-displayor-set-completions ((obj semantic-displayor-ghost)
1697 table prefix)
1698 "Set the list of tags to be completed over to TABLE."
1699 (call-next-method)
1700
1701 (semantic-displayor-cleanup obj)
1702 )
1703
1704
1705(defmethod semantic-displayor-show-request ((obj semantic-displayor-ghost))
1706 "A request to show the current tags table."
1707; (if (oref obj first-show)
1708; (progn
1709; (oset obj first-show nil)
1710 (semantic-displayor-focus-next obj)
1711 (semantic-displayor-focus-request obj)
1712; )
1713 ;; Only do the traditional thing if the first show request
1714 ;; has been seen. Use the first one to start doing the ghost
1715 ;; text display.
1716; (call-next-method)
1717; )
1718)
1719
1720(defmethod semantic-displayor-focus-request
1721 ((obj semantic-displayor-ghost))
1722 "Focus in on possible tag completions.
1723Focus is performed by cycling through the tags and showing a possible
1724completion text in ghost text."
1725 (let* ((tablelength (semanticdb-find-result-length (oref obj table)))
1726 (focus (semantic-displayor-focus-tag obj))
1727 (tag (car focus))
1728 )
1729 (if (not tag)
1730 (semantic-completion-message "No tags to focus on.")
1731 ;; Display the focus completion as ghost text after the current
1732 ;; inline text.
1733 (when (or (not (slot-boundp obj 'ghostoverlay))
1734 (not (semantic-overlay-live-p (oref obj ghostoverlay))))
1735 (oset obj ghostoverlay
1736 (semantic-make-overlay (point) (1+ (point)) (current-buffer) t)))
1737
1738 (let* ((lp (semantic-completion-text))
1739 (os (substring (semantic-tag-name tag) (length lp)))
1740 (ol (oref obj ghostoverlay))
1741 )
1742
1743 (put-text-property 0 (length os) 'face 'region os)
1744
1745 (semantic-overlay-put
1746 ol 'display (concat os (buffer-substring (point) (1+ (point)))))
1747 )
1748 ;; Calculate text difference between contents and the focus item.
1749 (let* ((mbc (semantic-completion-text))
1750 (ftn (concat (semantic-tag-name tag)))
1751 )
1752 (put-text-property (length mbc) (length ftn) 'face
1753 'bold ftn)
1754 (semantic-completion-message
1755 (format "%s [%d of %d matches]" ftn (1+ (oref obj focus)) tablelength)))
1756 )))
1757
1758
1759;;; ------------------------------------------------------------
1760;;; Specific queries
1761;;
1762(defun semantic-complete-read-tag-buffer-deep (prompt &optional
1763 default-tag
1764 initial-input
1765 history)
1766 "Ask for a tag by name from the current buffer.
1767Available tags are from the current buffer, at any level.
1768Completion options are presented in a traditional way, with highlighting
1769to resolve same-name collisions.
1770PROMPT is a string to prompt with.
1771DEFAULT-TAG is a semantic tag or string to use as the default value.
1772If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
1773HISTORY is a symbol representing a variable to store the history in."
1774 (semantic-complete-read-tag-engine
1775 (semantic-collector-buffer-deep prompt :buffer (current-buffer))
1776 (semantic-displayor-traditional-with-focus-highlight "simple")
1777 ;;(semantic-displayor-tooltip "simple")
1778 prompt
1779 default-tag
1780 initial-input
1781 history)
1782 )
1783
1784(defun semantic-complete-read-tag-project (prompt &optional
1785 default-tag
1786 initial-input
1787 history)
1788 "Ask for a tag by name from the current project.
1789Available tags are from the current project, at the top level.
1790Completion options are presented in a traditional way, with highlighting
1791to resolve same-name collisions.
1792PROMPT is a string to prompt with.
1793DEFAULT-TAG is a semantic tag or string to use as the default value.
1794If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
1795HISTORY is a symbol representing a variable to store the history in."
1796 (semantic-complete-read-tag-engine
1797 (semantic-collector-project-brutish prompt
1798 :buffer (current-buffer)
1799 :path (current-buffer)
1800 )
1801 (semantic-displayor-traditional-with-focus-highlight "simple")
1802 prompt
1803 default-tag
1804 initial-input
1805 history)
1806 )
1807
1808(defun semantic-complete-inline-tag-project ()
1809 "Complete a symbol name by name from within the current project.
1810This is similar to `semantic-complete-read-tag-project', except
1811that the completion interaction is in the buffer where the context
1812was calculated from.
1813Customize `semantic-complete-inline-analyzer-displayor-class'
1814to control how completion options are displayed.
1815See `semantic-complete-inline-tag-engine' for details on how
1816completion works."
1817 (let* ((collector (semantic-collector-project-brutish
1818 "inline"
1819 :buffer (current-buffer)
1820 :path (current-buffer)))
1821 (sbounds (semantic-ctxt-current-symbol-and-bounds))
1822 (syms (car sbounds))
1823 (start (car (nth 2 sbounds)))
1824 (end (cdr (nth 2 sbounds)))
1825 (rsym (reverse syms))
1826 (thissym (nth 1 sbounds))
1827 (nextsym (car-safe (cdr rsym)))
1828 (complst nil))
1829 (when (and thissym (or (not (string= thissym ""))
1830 nextsym))
1831 ;; Do a quick calcuation of completions.
1832 (semantic-collector-calculate-completions
1833 collector thissym nil)
1834 ;; Get the master list
1835 (setq complst (semanticdb-strip-find-results
1836 (semantic-collector-all-completions collector thissym)))
1837 ;; Shorten by name
1838 (setq complst (semantic-unique-tag-table-by-name complst))
1839 (if (or (and (= (length complst) 1)
1840 ;; Check to see if it is the same as what is there.
1841 ;; if so, we can offer to complete.
1842 (let ((compname (semantic-tag-name (car complst))))
1843 (not (string= compname thissym))))
1844 (> (length complst) 1))
1845 ;; There are several options. Do the completion.
1846 (semantic-complete-inline-tag-engine
1847 collector
1848 (funcall semantic-complete-inline-analyzer-displayor-class
1849 "inline displayor")
1850 ;;(semantic-displayor-tooltip "simple")
1851 (current-buffer)
1852 start end))
1853 )))
1854
1855(defun semantic-complete-read-tag-analyzer (prompt &optional
1856 context
1857 history)
1858 "Ask for a tag by name based on the current context.
1859The function `semantic-analyze-current-context' is used to
1860calculate the context. `semantic-analyze-possible-completions' is used
1861to generate the list of possible completions.
1862PROMPT is the first part of the prompt. Additional prompt
1863is added based on the contexts full prefix.
1864CONTEXT is the semantic analyzer context to start with.
1865HISTORY is a symbol representing a variable to stor the history in.
1866usually a default-tag and initial-input are available for completion
1867prompts. these are calculated from the CONTEXT variable passed in."
1868 (if (not context) (setq context (semantic-analyze-current-context (point))))
1869 (let* ((syms (semantic-ctxt-current-symbol (point)))
1870 (inp (car (reverse syms))))
1871 (setq syms (nreverse (cdr (nreverse syms))))
1872 (semantic-complete-read-tag-engine
1873 (semantic-collector-analyze-completions
1874 prompt
1875 :buffer (oref context buffer)
1876 :context context)
1877 (semantic-displayor-traditional-with-focus-highlight "simple")
1878 (save-excursion
1879 (set-buffer (oref context buffer))
1880 (goto-char (cdr (oref context bounds)))
1881 (concat prompt (mapconcat 'identity syms ".")
1882 (if syms "." "")
1883 ))
1884 nil
1885 inp
1886 history)))
1887
1888(defvar semantic-complete-inline-custom-type
1889 (append '(radio)
1890 (mapcar
1891 (lambda (class)
1892 (let* ((C (intern (car class)))
1893 (doc (documentation-property C 'variable-documentation))
1894 (doc1 (car (split-string doc "\n")))
1895 )
1896 (list 'const
1897 :tag doc1
1898 C)))
1899 (eieio-build-class-alist semantic-displayor-abstract t))
1900 )
1901 "Possible options for inlince completion displayors.
1902Use this to enable custom editing.")
1903
1904(defcustom semantic-complete-inline-analyzer-displayor-class
1905 'semantic-displayor-traditional
1906 "*Class for displayor to use with inline completion."
1907 :group 'semantic
1908 :type semantic-complete-inline-custom-type
1909 )
1910
1911
1912(defun semantic-complete-inline-analyzer (context)
1913 "Complete a symbol name by name based on the current context.
1914This is similar to `semantic-complete-read-tag-analyze', except
1915that the completion interaction is in the buffer where the context
1916was calculated from.
1917CONTEXT is the semantic analyzer context to start with.
1918Customize `semantic-complete-inline-analyzer-displayor-class'
1919to control how completion options are displayed.
1920
1921See `semantic-complete-inline-tag-engine' for details on how
1922completion works."
1923 (if (not context) (setq context (semantic-analyze-current-context (point))))
1924 (if (not context) (error "Nothing to complete on here"))
1925 (let* ((collector (semantic-collector-analyze-completions
1926 "inline"
1927 :buffer (oref context buffer)
1928 :context context))
1929 (syms (semantic-ctxt-current-symbol (point)))
1930 (rsym (reverse syms))
1931 (thissym (car rsym))
1932 (nextsym (car-safe (cdr rsym)))
1933 (complst nil))
1934 (when (and thissym (or (not (string= thissym ""))
1935 nextsym))
1936 ;; Do a quick calcuation of completions.
1937 (semantic-collector-calculate-completions
1938 collector thissym nil)
1939 ;; Get the master list
1940 (setq complst (semanticdb-strip-find-results
1941 (semantic-collector-all-completions collector thissym)))
1942 ;; Shorten by name
1943 (setq complst (semantic-unique-tag-table-by-name complst))
1944 (if (or (and (= (length complst) 1)
1945 ;; Check to see if it is the same as what is there.
1946 ;; if so, we can offer to complete.
1947 (let ((compname (semantic-tag-name (car complst))))
1948 (not (string= compname thissym))))
1949 (> (length complst) 1))
1950 ;; There are several options. Do the completion.
1951 (semantic-complete-inline-tag-engine
1952 collector
1953 (funcall semantic-complete-inline-analyzer-displayor-class
1954 "inline displayor")
1955 ;;(semantic-displayor-tooltip "simple")
1956 (oref context buffer)
1957 (car (oref context bounds))
1958 (cdr (oref context bounds))
1959 ))
1960 )))
1961
1962(defcustom semantic-complete-inline-analyzer-idle-displayor-class
1963 'semantic-displayor-ghost
1964 "*Class for displayor to use with inline completion at idle time."
1965 :group 'semantic
1966 :type semantic-complete-inline-custom-type
1967 )
1968
1969(defun semantic-complete-inline-analyzer-idle (context)
1970 "Complete a symbol name by name based on the current context for idle time.
1971CONTEXT is the semantic analyzer context to start with.
1972This function is used from `semantic-idle-completions-mode'.
1973
1974This is the same as `semantic-complete-inline-analyzer', except that
1975it uses `semantic-complete-inline-analyzer-idle-displayor-class'
1976to control how completions are displayed.
1977
1978See `semantic-complete-inline-tag-engine' for details on how
1979completion works."
1980 (let ((semantic-complete-inline-analyzer-displayor-class
1981 semantic-complete-inline-analyzer-idle-displayor-class))
1982 (semantic-complete-inline-analyzer context)
1983 ))
1984
1985
1986;;; ------------------------------------------------------------
1987;;; Testing/Samples
1988;;
1989(defun semantic-complete-test ()
1990 "Test completion mechanisms."
1991 (interactive)
1992 (message "%S"
1993 (semantic-format-tag-prototype
1994 (semantic-complete-read-tag-project "Symbol: ")
1995 )))
1996
1997(defun semantic-complete-jump-local ()
1998 "Jump to a semantic symbol."
1999 (interactive)
2000 (let ((tag (semantic-complete-read-tag-buffer-deep "Symbol: ")))
2001 (when (semantic-tag-p tag)
2002 (push-mark)
2003 (goto-char (semantic-tag-start tag))
2004 (semantic-momentary-highlight-tag tag)
2005 (message "%S: %s "
2006 (semantic-tag-class tag)
2007 (semantic-tag-name tag)))))
2008
2009(defun semantic-complete-jump ()
2010 "Jump to a semantic symbol."
2011 (interactive)
2012 (let* ((tag (semantic-complete-read-tag-project "Symbol: ")))
2013 (when (semantic-tag-p tag)
2014 (push-mark)
2015 (semantic-go-to-tag tag)
2016 (switch-to-buffer (current-buffer))
2017 (semantic-momentary-highlight-tag tag)
2018 (message "%S: %s "
2019 (semantic-tag-class tag)
2020 (semantic-tag-name tag)))))
2021
2022(defun semantic-complete-analyze-and-replace ()
2023 "Perform prompt completion to do in buffer completion.
2024`semantic-analyze-possible-completions' is used to determine the
2025possible values.
2026The minibuffer is used to perform the completion.
2027The result is inserted as a replacement of the text that was there."
2028 (interactive)
2029 (let* ((c (semantic-analyze-current-context (point)))
2030 (tag (save-excursion (semantic-complete-read-tag-analyzer "" c))))
2031 ;; Take tag, and replace context bound with its name.
2032 (goto-char (car (oref c bounds)))
2033 (delete-region (point) (cdr (oref c bounds)))
2034 (insert (semantic-tag-name tag))
2035 (message "%S" (semantic-format-tag-summarize tag))))
2036
2037(defun semantic-complete-analyze-inline ()
2038 "Perform prompt completion to do in buffer completion.
2039`semantic-analyze-possible-completions' is used to determine the
2040possible values.
2041The function returns immediately, leaving the buffer in a mode that
2042will perform the completion.
2043Configure `semantic-complete-inline-analyzer-displayor-class' to change
2044how completion options are displayed."
2045 (interactive)
2046 ;; Only do this if we are not already completing something.
2047 (if (not (semantic-completion-inline-active-p))
2048 (semantic-complete-inline-analyzer
2049 (semantic-analyze-current-context (point))))
2050 ;; Report a message if things didn't startup.
2051 (if (and (interactive-p)
2052 (not (semantic-completion-inline-active-p)))
2053 (message "Inline completion not needed.")
2054 ;; Since this is most likely bound to something, and not used
2055 ;; at idle time, throw in a TAB for good measure.
2056 (semantic-complete-inline-TAB)
2057 ))
2058
2059(defun semantic-complete-analyze-inline-idle ()
2060 "Perform prompt completion to do in buffer completion.
2061`semantic-analyze-possible-completions' is used to determine the
2062possible values.
2063The function returns immediately, leaving the buffer in a mode that
2064will perform the completion.
2065Configure `semantic-complete-inline-analyzer-idle-displayor-class'
2066to change how completion options are displayed."
2067 (interactive)
2068 ;; Only do this if we are not already completing something.
2069 (if (not (semantic-completion-inline-active-p))
2070 (semantic-complete-inline-analyzer-idle
2071 (semantic-analyze-current-context (point))))
2072 ;; Report a message if things didn't startup.
2073 (if (and (interactive-p)
2074 (not (semantic-completion-inline-active-p)))
2075 (message "Inline completion not needed."))
2076 )
2077
2078(defun semantic-complete-self-insert (arg)
2079 "Like `self-insert-command', but does completion afterwards.
2080ARG is passed to `self-insert-command'. If ARG is nil,
2081use `semantic-complete-analyze-inline' to complete."
2082 (interactive "p")
2083 ;; If we are already in a completion scenario, exit now, and then start over.
2084 (semantic-complete-inline-exit)
2085
2086 ;; Insert the key
2087 (self-insert-command arg)
2088
2089 ;; Prepare for doing completion, but exit quickly if there is keyboard
2090 ;; input.
2091 (when (and (not (semantic-exit-on-input 'csi
2092 (semantic-fetch-tags)
2093 (semantic-throw-on-input 'csi)
2094 nil))
2095 (= arg 1)
2096 (not (semantic-exit-on-input 'csi
2097 (semantic-analyze-current-context)
2098 (semantic-throw-on-input 'csi)
2099 nil)))
2100 (condition-case nil
2101 (semantic-complete-analyze-inline)
2102 ;; Ignore errors. Seems likely that we'll get some once in a while.
2103 (error nil))
2104 ))
2105
2106;; @TODO - I can't find where this fcn is used. Delete?
2107
2108;;;;###autoload
2109;(defun semantic-complete-inline-project ()
2110; "Perform inline completion for any symbol in the current project.
2111;`semantic-analyze-possible-completions' is used to determine the
2112;possible values.
2113;The function returns immediately, leaving the buffer in a mode that
2114;will perform the completion."
2115; (interactive)
2116; ;; Only do this if we are not already completing something.
2117; (if (not (semantic-completion-inline-active-p))
2118; (semantic-complete-inline-tag-project))
2119; ;; Report a message if things didn't startup.
2120; (if (and (interactive-p)
2121; (not (semantic-completion-inline-active-p)))
2122; (message "Inline completion not needed."))
2123; )
2124
2125;; End
2126(provide 'semantic/complete)
2127
2128;;; semantic-complete.el ends here
diff --git a/lisp/cedet/semantic/edit.el b/lisp/cedet/semantic/edit.el
new file mode 100644
index 00000000000..af3b23a3600
--- /dev/null
+++ b/lisp/cedet/semantic/edit.el
@@ -0,0 +1,965 @@
1;;; semantic-edit.el --- Edit Management for Semantic
2
3;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
4;;; 2007, 2008, 2009 Free Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24;;
25;; In Semantic 1.x, changes were handled in a simplistic manner, where
26;; tags that changed were reparsed one at a time. Any other form of
27;; edit were managed through a full reparse.
28;;
29;; This code attempts to minimize the number of times a full reparse
30;; needs to occur. While overlays and tags will continue to be
31;; recycled in the simple case, new cases where tags are inserted
32;; or old tags removed from the original list are handled.
33;;
34
35;;; NOTES FOR IMPROVEMENT
36;;
37;; Work done by the incremental parser could be improved by the
38;; following:
39;;
40;; 1. Tags created could have as a property an overlay marking a region
41;; of themselves that can be edited w/out affecting the definition of
42;; that tag.
43;;
44;; 2. Tags w/ positioned children could have a property of an
45;; overlay marking the region in themselves that contain the
46;; children. This could be used to better improve splicing near
47;; the beginning and end of the child lists.
48;;
49
50;;; BUGS IN INCREMENTAL PARSER
51;;
52;; 1. Changes in the whitespace between tags could extend a
53;; following tag. These will be marked as merely unmatched
54;; syntax instead.
55;;
56;; 2. Incremental parsing while a new function is being typed in
57;; somtimes gets a chance only when lists are incomplete,
58;; preventing correct context identification.
59
60;;
61(require 'semantic)
62;; (require 'working)
63
64;;; Code:
65(defvar semantic-after-partial-cache-change-hook nil
66 "Hooks run after the buffer cache has been updated.
67
68This hook will run when the cache has been partially reparsed.
69Partial reparses are incurred when a user edits a buffer, and only the
70modified sections are rescanned.
71
72Hook functions must take one argument, which is the list of tags
73updated in the current buffer.
74
75For language specific hooks, make sure you define this as a local hook.")
76
77(defvar semantic-change-hooks nil
78 "Hooks run when semantic detects a change in a buffer.
79Each hook function must take three arguments, identical to the
80common hook `after-change-functions'.")
81
82(defvar semantic-reparse-needed-change-hook nil
83 "Hooks run when a user edit is detected as needing a reparse.
84For language specific hooks, make sure you define this as a local
85hook.
86Not used yet; part of the next generation reparse mechanism")
87
88(defvar semantic-no-reparse-needed-change-hook nil
89 "Hooks run when a user edit is detected as not needing a reparse.
90If the hook returns non-nil, then declare that a reparse is needed.
91For language specific hooks, make sure you define this as a local
92hook.
93Not used yet; part of the next generation reparse mechanism.")
94
95(defvar semantic-edits-new-change-hooks nil
96 "Hooks run when a new change is found.
97Functions must take one argument representing an overlay on that change.")
98
99(defvar semantic-edits-delete-change-hooks nil
100 "Hooks run before a change overlay is deleted.
101Deleted changes occur when multiple changes are merged.
102Functions must take one argument representing an overlay being deleted.")
103
104(defvar semantic-edits-move-change-hooks nil
105 "Hooks run after a change overlay is moved.
106Changes move when a new change overlaps an old change. The old change
107will be moved.
108Functions must take one argument representing an overlay being moved.")
109
110(defvar semantic-edits-reparse-change-hooks nil
111 "Hooks run after a change results in a reparse.
112Functions are called before the overlay is deleted, and after the
113incremental reparse.")
114
115(defvar semantic-edits-incremental-reparse-failed-hooks nil
116 "Hooks run after the incremental parser fails.
117When this happens, the buffer is marked as needing a full reprase.")
118
119(defcustom semantic-edits-verbose-flag nil
120 "Non-nil means the incremental perser is verbose.
121If nil, errors are still displayed, but informative messages are not."
122 :group 'semantic
123 :type 'boolean)
124
125;;; Change State management
126;;
127;; Manage a series of overlays that define changes recently
128;; made to the current buffer.
129(defun semantic-change-function (start end length)
130 "Provide a mechanism for semantic tag management.
131Argument START, END, and LENGTH specify the bounds of the change."
132 (setq semantic-unmatched-syntax-cache-check t)
133 (let ((inhibit-point-motion-hooks t)
134 )
135 (run-hook-with-args 'semantic-change-hooks start end length)
136 ))
137
138(defun semantic-changes-in-region (start end &optional buffer)
139 "Find change overlays which exist in whole or in part between START and END.
140Optional argument BUFFER is the buffer to search for changes in."
141 (save-excursion
142 (if buffer (set-buffer buffer))
143 (let ((ol (semantic-overlays-in (max start (point-min))
144 (min end (point-max))))
145 (ret nil))
146 (while ol
147 (when (semantic-overlay-get (car ol) 'semantic-change)
148 (setq ret (cons (car ol) ret)))
149 (setq ol (cdr ol)))
150 (sort ret #'(lambda (a b) (< (semantic-overlay-start a)
151 (semantic-overlay-start b)))))))
152
153(defun semantic-edits-change-function-handle-changes (start end length)
154 "Run whenever a buffer controlled by `semantic-mode' change.
155Tracks when and how the buffer is re-parsed.
156Argument START, END, and LENGTH specify the bounds of the change."
157 ;; We move start/end by one so that we can merge changes that occur
158 ;; just before, or just after. This lets simple typing capture everything
159 ;; into one overlay.
160 (let ((changes-in-change (semantic-changes-in-region (1- start) (1+ end)))
161 )
162 (semantic-parse-tree-set-needs-update)
163 (if (not changes-in-change)
164 (let ((o (semantic-make-overlay start end)))
165 (semantic-overlay-put o 'semantic-change t)
166 ;; Run the hooks safely. When hooks blow it, our dirty
167 ;; function will be removed from the list of active change
168 ;; functions.
169 (condition-case nil
170 (run-hook-with-args 'semantic-edits-new-change-hooks o)
171 (error nil)))
172 (let ((tmp changes-in-change))
173 ;; Find greatest bounds of all changes
174 (while tmp
175 (when (< (semantic-overlay-start (car tmp)) start)
176 (setq start (semantic-overlay-start (car tmp))))
177 (when (> (semantic-overlay-end (car tmp)) end)
178 (setq end (semantic-overlay-end (car tmp))))
179 (setq tmp (cdr tmp)))
180 ;; Move the first found overlay, recycling that overlay.
181 (semantic-overlay-move (car changes-in-change) start end)
182 (condition-case nil
183 (run-hook-with-args 'semantic-edits-move-change-hooks
184 (car changes-in-change))
185 (error nil))
186 (setq changes-in-change (cdr changes-in-change))
187 ;; Delete other changes. They are now all bound here.
188 (while changes-in-change
189 (condition-case nil
190 (run-hook-with-args 'semantic-edits-delete-change-hooks
191 (car changes-in-change))
192 (error nil))
193 (semantic-overlay-delete (car changes-in-change))
194 (setq changes-in-change (cdr changes-in-change))))
195 )))
196
197(defsubst semantic-edits-flush-change (change)
198 "Flush the CHANGE overlay."
199 (condition-case nil
200 (run-hook-with-args 'semantic-edits-delete-change-hooks
201 change)
202 (error nil))
203 (semantic-overlay-delete change))
204
205(defun semantic-edits-flush-changes ()
206 "Flush the changes in the current buffer."
207 (let ((changes (semantic-changes-in-region (point-min) (point-max))))
208 (while changes
209 (semantic-edits-flush-change (car changes))
210 (setq changes (cdr changes))))
211 )
212
213(defun semantic-edits-change-in-one-tag-p (change hits)
214 "Return non-nil of the overlay CHANGE exists solely in one leaf tag.
215HITS is the list of tags that CHANGE is in. It can have more than
216one tag in it if the leaf tag is within a parent tag."
217 (and (< (semantic-tag-start (car hits))
218 (semantic-overlay-start change))
219 (> (semantic-tag-end (car hits))
220 (semantic-overlay-end change))
221 ;; Recurse on the rest. If this change is inside all
222 ;; of these tags, then they are all leaves or parents
223 ;; of the smallest tag.
224 (or (not (cdr hits))
225 (semantic-edits-change-in-one-tag-p change (cdr hits))))
226 )
227
228;;; Change/Tag Query functions
229;;
230;; A change (region of space) can effect tags in different ways.
231;; These functions perform queries on a buffer to determine different
232;; ways that a change effects a buffer.
233;;
234;; NOTE: After debugging these, replace below to no longer look
235;; at point and mark (via comments I assume.)
236(defsubst semantic-edits-os (change)
237 "For testing: Start of CHANGE, or smaller of (point) and (mark)."
238 (if change (semantic-overlay-start change)
239 (if (< (point) (mark)) (point) (mark))))
240
241(defsubst semantic-edits-oe (change)
242 "For testing: End of CHANGE, or larger of (point) and (mark)."
243 (if change (semantic-overlay-end change)
244 (if (> (point) (mark)) (point) (mark))))
245
246(defun semantic-edits-change-leaf-tag (change)
247 "A leaf tag which completely encompasses CHANGE.
248If change overlaps a tag, but is not encompassed in it, return nil.
249Use `semantic-edits-change-overlap-leaf-tag'.
250If CHANGE is completely encompassed in a tag, but overlaps sub-tags,
251return nil."
252 (let* ((start (semantic-edits-os change))
253 (end (semantic-edits-oe change))
254 (tags (nreverse
255 (semantic-find-tag-by-overlay-in-region
256 start end))))
257 ;; A leaf is always first in this list
258 (if (and tags
259 (<= (semantic-tag-start (car tags)) start)
260 (> (semantic-tag-end (car tags)) end))
261 ;; Ok, we have a match. If this tag has children,
262 ;; we have to do more tests.
263 (let ((chil (semantic-tag-components (car tags))))
264 (if (not chil)
265 ;; Simple leaf.
266 (car tags)
267 ;; For this type, we say that we encompass it if the
268 ;; change occurs outside the range of the children.
269 (if (or (not (semantic-tag-with-position-p (car chil)))
270 (> start (semantic-tag-end (nth (1- (length chil)) chil)))
271 (< end (semantic-tag-start (car chil))))
272 ;; We have modifications to the definition of this parent
273 ;; so we have to reparse the whole thing.
274 (car tags)
275 ;; We actually modified an area between some children.
276 ;; This means we should return nil, as that case is
277 ;; calculated by someone else.
278 nil)))
279 nil)))
280
281(defun semantic-edits-change-between-tags (change)
282 "Return a cache list of tags surrounding CHANGE.
283The returned list is the CONS cell in the master list pointing to
284a tag just before CHANGE. The CDR will have the tag just after CHANGE.
285CHANGE cannot encompass or overlap a leaf tag.
286If CHANGE is fully encompassed in a tag that has children, and
287this change occurs between those children, this returns non-nil.
288See `semantic-edits-change-leaf-tag' for details on parents."
289 (let* ((start (semantic-edits-os change))
290 (end (semantic-edits-oe change))
291 (tags (nreverse
292 (semantic-find-tag-by-overlay-in-region
293 start end)))
294 (list-to-search nil)
295 (found nil))
296 (if (not tags)
297 (setq list-to-search semantic--buffer-cache)
298 ;; A leaf is always first in this list
299 (if (and (< (semantic-tag-start (car tags)) start)
300 (> (semantic-tag-end (car tags)) end))
301 ;; We are completely encompassed in a tag.
302 (if (setq list-to-search
303 (semantic-tag-components (car tags)))
304 ;; Ok, we are completely encompassed within the first tag
305 ;; entry, AND that tag has children. This means that change
306 ;; occured outside of all children, but inside some tag
307 ;; with children.
308 (if (or (not (semantic-tag-with-position-p (car list-to-search)))
309 (> start (semantic-tag-end
310 (nth (1- (length list-to-search))
311 list-to-search)))
312 (< end (semantic-tag-start (car list-to-search))))
313 ;; We have modifications to the definition of this parent
314 ;; and not between it's children. Clear the search list.
315 (setq list-to-search nil)))
316 ;; Search list is nil.
317 ))
318 ;; If we have a search list, lets go. Otherwise nothing.
319 (while (and list-to-search (not found))
320 (if (cdr list-to-search)
321 ;; We end when the start of the CDR is after the end of our
322 ;; asked change.
323 (if (< (semantic-tag-start (cadr list-to-search)) end)
324 (setq list-to-search (cdr list-to-search))
325 (setq found t))
326 (setq list-to-search nil)))
327 ;; Return it. If it is nil, there is a logic bug, and we need
328 ;; to avoid this bit of logic anyway.
329 list-to-search
330 ))
331
332(defun semantic-edits-change-over-tags (change)
333 "Return a cache list of tags surrounding a CHANGE encompassing tags.
334CHANGE must not only include all overlapped tags (excepting possible
335parent tags) in their entirety. In this case, the change may be deleting
336or moving whole tags.
337The return value is a vector.
338Cell 0 is a list of all tags completely encompassed in change.
339Cell 1 is the cons cell into a master parser cache starting with
340the cell which occurs BEFORE the first position of CHANGE.
341Cell 2 is the parent of cell 1, or nil for the buffer cache.
342This function returns nil if any tag covered by change is not
343completely encompassed.
344See `semantic-edits-change-leaf-tag' for details on parents."
345 (let* ((start (semantic-edits-os change))
346 (end (semantic-edits-oe change))
347 (tags (nreverse
348 (semantic-find-tag-by-overlay-in-region
349 start end)))
350 (parent nil)
351 (overlapped-tags nil)
352 inner-start inner-end
353 (list-to-search nil))
354 ;; By the time this is already called, we know that it is
355 ;; not a leaf change, nor a between tag change. That leaves
356 ;; an overlap, and this condition.
357
358 ;; A leaf is always first in this list.
359 ;; Is the leaf encompassed in this change?
360 (if (and tags
361 (>= (semantic-tag-start (car tags)) start)
362 (<= (semantic-tag-end (car tags)) end))
363 (progn
364 ;; We encompass one whole change.
365 (setq overlapped-tags (list (car tags))
366 inner-start (semantic-tag-start (car tags))
367 inner-end (semantic-tag-end (car tags))
368 tags (cdr tags))
369 ;; Keep looping while tags are inside the change.
370 (while (and tags
371 (>= (semantic-tag-start (car tags)) start)
372 (<= (semantic-tag-end (car tags)) end))
373
374 ;; Check if this new all-encompassing tag is a parent
375 ;; of that which went before. Only check end because
376 ;; we know that start is less than inner-start since
377 ;; tags was sorted on that.
378 (if (> (semantic-tag-end (car tags)) inner-end)
379 ;; This is a parent. Drop the children found
380 ;; so far.
381 (setq overlapped-tags (list (car tags))
382 inner-start (semantic-tag-start (car tags))
383 inner-end (semantic-tag-end (car tags))
384 )
385 ;; It is not a parent encompassing tag
386 (setq overlapped-tags (cons (car tags)
387 overlapped-tags)
388 inner-start (semantic-tag-start (car tags))))
389 (setq tags (cdr tags)))
390 (if (not tags)
391 ;; There are no tags left, and all tags originally
392 ;; found are encompassed by the change. Setup our list
393 ;; from the cache
394 (setq list-to-search semantic--buffer-cache);; We have a tag ouside the list. Check for
395 ;; We know we have a parent because it would
396 ;; completely cover the change. A tag can only
397 ;; do that if it is a parent after we get here.
398 (when (and tags
399 (< (semantic-tag-start (car tags)) start)
400 (> (semantic-tag-end (car tags)) end))
401 ;; We have a parent. Stuff in the search list.
402 (setq parent (car tags)
403 list-to-search (semantic-tag-components parent))
404 ;; If the first of TAGS is a parent (see above)
405 ;; then clear out the list. All other tags in
406 ;; here must therefore be parents of the car.
407 (setq tags nil)
408 ;; One last check, If start is before the first
409 ;; tag or after the last, we may have overlap into
410 ;; the characters that make up the definition of
411 ;; the tag we are parsing.
412 (when (or (semantic-tag-with-position-p (car list-to-search))
413 (< start (semantic-tag-start
414 (car list-to-search)))
415 (> end (semantic-tag-end
416 (nth (1- (length list-to-search))
417 list-to-search))))
418 ;; We have a problem
419 (setq list-to-search nil
420 parent nil))))
421
422 (when list-to-search
423
424 ;; Ok, return the vector only if all TAGS are
425 ;; confirmed as the lineage of `overlapped-tags'
426 ;; which must have a value by now.
427
428 ;; Loop over the search list to find the preceeding CDR.
429 ;; Fortunatly, (car overlapped-tags) happens to be
430 ;; the first tag positionally.
431 (let ((tokstart (semantic-tag-start (car overlapped-tags))))
432 (while (and list-to-search
433 ;; Assume always (car (cdr list-to-search)).
434 ;; A thrown error will be captured nicely, but
435 ;; that case shouldn't happen.
436
437 ;; We end when the start of the CDR is after the
438 ;; end of our asked change.
439 (cdr list-to-search)
440 (< (semantic-tag-start (car (cdr list-to-search)))
441 tokstart)
442 (setq list-to-search (cdr list-to-search)))))
443 ;; Create the return vector
444 (vector overlapped-tags
445 list-to-search
446 parent)
447 ))
448 nil)))
449
450;;; Default Incremental Parser
451;;
452;; Logic about how to group changes for effective reparsing and splicing.
453
454(defun semantic-parse-changes-failed (&rest args)
455 "Signal that Semantic failed to parse changes.
456That is, display a message by passing all ARGS to `format', then throw
457a 'semantic-parse-changes-failed exception with value t."
458 (when semantic-edits-verbose-flag
459 (message "Semantic parse changes failed: %S"
460 (apply 'format args)))
461 (throw 'semantic-parse-changes-failed t))
462
463(defsubst semantic-edits-incremental-fail ()
464 "When the incremental parser fails, we mark that we need a full reparse."
465 ;;(debug)
466 (semantic-parse-tree-set-needs-rebuild)
467 (when semantic-edits-verbose-flag
468 (message "Force full reparse (%s)"
469 (buffer-name (current-buffer))))
470 (run-hooks 'semantic-edits-incremental-reparse-failed-hooks))
471
472(defun semantic-edits-incremental-parser ()
473 "Incrementally reparse the current buffer.
474Incremental parser allows semantic to only reparse those sections of
475the buffer that have changed. This function depends on
476`semantic-edits-change-function-handle-changes' setting up change
477overlays in the current buffer. Those overlays are analyzed against
478the semantic cache to see what needs to be changed."
479 (let ((changed-tags
480 ;; Don't use `semantic-safe' here to explicitly catch errors
481 ;; and reset the parse tree.
482 (catch 'semantic-parse-changes-failed
483 (if debug-on-error
484 (semantic-edits-incremental-parser-1)
485 (condition-case err
486 (semantic-edits-incremental-parser-1)
487 (error
488 (message "incremental parser error: %S"
489 (error-message-string err))
490 t))))))
491 (when (eq changed-tags t)
492 ;; Force a full reparse.
493 (semantic-edits-incremental-fail)
494 (setq changed-tags nil))
495 changed-tags))
496
497(defmacro semantic-edits-assert-valid-region ()
498 "Asert that parse-start and parse-end are sorted correctly."
499;;; (if (> parse-start parse-end)
500;;; (error "Bug is %s !> %d! Buff min/max = [ %d %d ]"
501;;; parse-start parse-end
502;;; (point-min) (point-max)))
503 )
504
505(defun semantic-edits-incremental-parser-1 ()
506 "Incrementally reparse the current buffer.
507Return the list of tags that changed.
508If the incremental parse fails, throw a 'semantic-parse-changes-failed
509exception with value t, that can be caught to schedule a full reparse.
510This function is for internal use by `semantic-edits-incremental-parser'."
511 (let* ((changed-tags nil)
512 (debug-on-quit t) ; try to find this annoying bug!
513 (changes (semantic-changes-in-region
514 (point-min) (point-max)))
515 (tags nil) ;tags found at changes
516 (newf-tags nil) ;newfound tags in change
517 (parse-start nil) ;location to start parsing
518 (parse-end nil) ;location to end parsing
519 (parent-tag nil) ;parent of the cache list.
520 (cache-list nil) ;list of children within which
521 ;we incrementally reparse.
522 (reparse-symbol nil) ;The ruled we start at for reparse.
523 (change-group nil) ;changes grouped in this reparse
524 (last-cond nil) ;track the last case used.
525 ;query this when debugging to find
526 ;source of bugs.
527 )
528 (or changes
529 ;; If we were called, and there are no changes, then we
530 ;; don't know what to do. Force a full reparse.
531 (semantic-parse-changes-failed "Don't know what to do"))
532 ;; Else, we have some changes. Loop over them attempting to
533 ;; patch things up.
534 (while changes
535 ;; Calculate the reparse boundary.
536 ;; We want to take some set of changes, and group them
537 ;; together into a small change group. One change forces
538 ;; a reparse of a larger region (the size of some set of
539 ;; tags it encompases.) It may contain several tags.
540 ;; That region may have other changes in it (several small
541 ;; changes in one function, for example.)
542 ;; Optimize for the simple cases here, but try to handle
543 ;; complex ones too.
544
545 (while (and changes ; we still have changes
546 (or (not parse-start)
547 ;; Below, if the change we are looking at
548 ;; is not the first change for this
549 ;; iteration, and it starts before the end
550 ;; of current parse region, then it is
551 ;; encompased within the bounds of tags
552 ;; modified by the previous iteration's
553 ;; change.
554 (< (semantic-overlay-start (car changes))
555 parse-end)))
556
557 ;; REMOVE LATER
558 (if (eq (car changes) (car change-group))
559 (semantic-parse-changes-failed
560 "Possible infinite loop detected"))
561
562 ;; Store this change in this change group.
563 (setq change-group (cons (car changes) change-group))
564
565 (cond
566 ;; Is this is a new parse group?
567 ((not parse-start)
568 (setq last-cond "new group")
569 (let (tmp)
570 (cond
571
572;;;; Are we encompassed all in one tag?
573 ((setq tmp (semantic-edits-change-leaf-tag (car changes)))
574 (setq last-cond "Encompassed in tag")
575 (setq tags (list tmp)
576 parse-start (semantic-tag-start tmp)
577 parse-end (semantic-tag-end tmp)
578 )
579 (semantic-edits-assert-valid-region))
580
581;;;; Did the change occur between some tags?
582 ((setq cache-list (semantic-edits-change-between-tags
583 (car changes)))
584 (setq last-cond "Between and not overlapping tags")
585 ;; The CAR of cache-list is the tag just before
586 ;; our change, but wasn't modified. Hmmm.
587 ;; Bound our reparse between these two tags
588 (setq tags nil
589 parent-tag
590 (car (semantic-find-tag-by-overlay
591 parse-start)))
592 (cond
593 ;; A change at the beginning of the buffer.
594 ;; Feb 06 -
595 ;; IDed when the first cache-list tag is after
596 ;; our change, meaning there is nothing before
597 ;; the chnge.
598 ((> (semantic-tag-start (car cache-list))
599 (semantic-overlay-end (car changes)))
600 (setq last-cond "Beginning of buffer")
601 (setq parse-start
602 ;; Don't worry about parents since
603 ;; there there would be an exact
604 ;; match in the tag list otherwise
605 ;; and the routine would fail.
606 (point-min)
607 parse-end
608 (semantic-tag-start (car cache-list)))
609 (semantic-edits-assert-valid-region)
610 )
611 ;; A change stuck on the first surrounding tag.
612 ((= (semantic-tag-end (car cache-list))
613 (semantic-overlay-start (car changes)))
614 (setq last-cond "Beginning of Tag")
615 ;; Reparse that first tag.
616 (setq parse-start
617 (semantic-tag-start (car cache-list))
618 parse-end
619 (semantic-overlay-end (car changes))
620 tags
621 (list (car cache-list)))
622 (semantic-edits-assert-valid-region)
623 )
624 ;; A change at the end of the buffer.
625 ((not (car (cdr cache-list)))
626 (setq last-cond "End of buffer")
627 (setq parse-start (semantic-tag-end
628 (car cache-list))
629 parse-end (point-max))
630 (semantic-edits-assert-valid-region)
631 )
632 (t
633 (setq last-cond "Default")
634 (setq parse-start
635 (semantic-tag-end (car cache-list))
636 parse-end
637 (semantic-tag-start (car (cdr cache-list)))
638 )
639 (semantic-edits-assert-valid-region))))
640
641;;;; Did the change completely overlap some number of tags?
642 ((setq tmp (semantic-edits-change-over-tags
643 (car changes)))
644 (setq last-cond "Overlap multiple tags")
645 ;; Extract the information
646 (setq tags (aref tmp 0)
647 cache-list (aref tmp 1)
648 parent-tag (aref tmp 2))
649 ;; We can calculate parse begin/end by checking
650 ;; out what is in TAGS. The one near start is
651 ;; always first. Make sure the reprase includes
652 ;; the `whitespace' around the snarfed tags.
653 ;; Since cache-list is positioned properly, use it
654 ;; to find that boundary.
655 (if (eq (car tags) (car cache-list))
656 ;; Beginning of the buffer!
657 (let ((end-marker (nth (length tags)
658 cache-list)))
659 (setq parse-start (point-min))
660 (if end-marker
661 (setq parse-end
662 (semantic-tag-start end-marker))
663 (setq parse-end (semantic-overlay-end
664 (car changes))))
665 (semantic-edits-assert-valid-region)
666 )
667 ;; Middle of the buffer.
668 (setq parse-start
669 (semantic-tag-end (car cache-list)))
670 ;; For the end, we need to scoot down some
671 ;; number of tags. We 1+ the length of tags
672 ;; because we want to skip the first tag
673 ;; (remove 1-) then want the tag after the end
674 ;; of the list (1+)
675 (let ((end-marker (nth (1+ (length tags)) cache-list)))
676 (if end-marker
677 (setq parse-end (semantic-tag-start end-marker))
678 ;; No marker. It is the last tag in our
679 ;; list of tags. Only possible if END
680 ;; already matches the end of that tag.
681 (setq parse-end
682 (semantic-overlay-end (car changes)))))
683 (semantic-edits-assert-valid-region)
684 ))
685
686;;;; Unhandled case.
687 ;; Throw error, and force full reparse.
688 ((semantic-parse-changes-failed "Unhandled change group")))
689 ))
690 ;; Is this change inside the previous parse group?
691 ;; We already checked start.
692 ((< (semantic-overlay-end (car changes)) parse-end)
693 (setq last-cond "in bounds")
694 nil)
695 ;; This change extends the current parse group.
696 ;; Find any new tags, and see how to append them.
697 ((semantic-parse-changes-failed
698 (setq last-cond "overlap boundary")
699 "Unhandled secondary change overlapping boundary"))
700 )
701 ;; Prepare for the next iteration.
702 (setq changes (cdr changes)))
703
704 ;; By the time we get here, all TAGS are children of
705 ;; some parent. They should all have the same start symbol
706 ;; since that is how the multi-tag parser works. Grab
707 ;; the reparse symbol from the first of the returned tags.
708 ;;
709 ;; Feb '06 - If repase-symbol is nil, then they are top level
710 ;; tags. (I'm guessing.) Is this right?
711 (setq reparse-symbol
712 (semantic--tag-get-property (car (or tags cache-list))
713 'reparse-symbol))
714 ;; Find a parent if not provided.
715 (and (not parent-tag) tags
716 (setq parent-tag
717 (semantic-find-tag-parent-by-overlay
718 (car tags))))
719 ;; We can do the same trick for our parent and resulting
720 ;; cache list.
721 (unless cache-list
722 (if parent-tag
723 (setq cache-list
724 ;; We need to get all children in case we happen
725 ;; to have a mix of positioned and non-positioned
726 ;; children.
727 (semantic-tag-components parent-tag))
728 ;; Else, all the tags since there is no parent.
729 ;; It sucks to have to use the full buffer cache in
730 ;; this case because it can be big. Failure to provide
731 ;; however results in a crash.
732 (setq cache-list semantic--buffer-cache)
733 ))
734 ;; Use the boundary to calculate the new tags found.
735 (setq newf-tags (semantic-parse-region
736 parse-start parse-end reparse-symbol))
737 ;; Make sure all these tags are given overlays.
738 ;; They have already been cooked by the parser and just
739 ;; need the overlays.
740 (let ((tmp newf-tags))
741 (while tmp
742 (semantic--tag-link-to-buffer (car tmp))
743 (setq tmp (cdr tmp))))
744
745 ;; See how this change lays out.
746 (cond
747
748;;;; Whitespace change
749 ((and (not tags) (not newf-tags))
750 ;; A change that occured outside of any existing tags
751 ;; and there are no new tags to replace it.
752 (when semantic-edits-verbose-flag
753 (message "White space changes"))
754 nil
755 )
756
757;;;; New tags in old whitespace area.
758 ((and (not tags) newf-tags)
759 ;; A change occured outside existing tags which added
760 ;; a new tag. We need to splice these tags back
761 ;; into the cache at the right place.
762 (semantic-edits-splice-insert newf-tags parent-tag cache-list)
763
764 (setq changed-tags
765 (append newf-tags changed-tags))
766
767 (when semantic-edits-verbose-flag
768 (message "Inserted tags: (%s)"
769 (semantic-format-tag-name (car newf-tags))))
770 )
771
772;;;; Old tags removed
773 ((and tags (not newf-tags))
774 ;; A change occured where pre-existing tags were
775 ;; deleted! Remove the tag from the cache.
776 (semantic-edits-splice-remove tags parent-tag cache-list)
777
778 (setq changed-tags
779 (append tags changed-tags))
780
781 (when semantic-edits-verbose-flag
782 (message "Deleted tags: (%s)"
783 (semantic-format-tag-name (car tags))))
784 )
785
786;;;; One tag was updated.
787 ((and (= (length tags) 1) (= (length newf-tags) 1))
788 ;; One old tag was modified, and it is replaced by
789 ;; One newfound tag. Splice the new tag into the
790 ;; position of the old tag.
791 ;; Do the splice.
792 (semantic-edits-splice-replace (car tags) (car newf-tags))
793 ;; Add this tag to our list of changed toksns
794 (setq changed-tags (cons (car tags) changed-tags))
795 ;; Debug
796 (when semantic-edits-verbose-flag
797 (message "Update Tag Table: %s"
798 (semantic-format-tag-name (car tags) nil t)))
799 ;; Flush change regardless of above if statement.
800 )
801
802;;;; Some unhandled case.
803 ((semantic-parse-changes-failed "Don't know what to do")))
804
805 ;; We got this far, and we didn't flag a full reparse.
806 ;; Clear out this change group.
807 (while change-group
808 (semantic-edits-flush-change (car change-group))
809 (setq change-group (cdr change-group)))
810
811 ;; Don't increment change here because an earlier loop
812 ;; created change-groups.
813 (setq parse-start nil)
814 )
815 ;; Mark that we are done with this glop
816 (semantic-parse-tree-set-up-to-date)
817 ;; Return the list of tags that changed. The caller will
818 ;; use this information to call hooks which can fix themselves.
819 changed-tags))
820
821;; Make it the default changes parser
822(defalias 'semantic-parse-changes-default
823 'semantic-edits-incremental-parser)
824
825;;; Cache Splicing
826;;
827;; The incremental parser depends on the ability to parse up sections
828;; of the file, and splice the results back into the cache. There are
829;; three types of splices. A REPLACE, an ADD, and a REMOVE. REPLACE
830;; is one of the simpler cases, as the starting cons cell representing
831;; the old tag can be used to auto-splice in. ADD and REMOVE
832;; require scanning the cache to find the correct location so that the
833;; list can be fiddled.
834(defun semantic-edits-splice-remove (oldtags parent cachelist)
835 "Remove OLDTAGS from PARENT's CACHELIST.
836OLDTAGS are tags in the currenet buffer, preferably linked
837together also in CACHELIST.
838PARENT is the parent tag containing OLDTAGS.
839CACHELIST should be the children from PARENT, but may be
840pre-positioned to a convenient location."
841 (let* ((first (car oldtags))
842 (last (nth (1- (length oldtags)) oldtags))
843 (chil (if parent
844 (semantic-tag-components parent)
845 semantic--buffer-cache))
846 (cachestart cachelist)
847 (cacheend nil)
848 )
849 ;; First in child list?
850 (if (eq first (car chil))
851 ;; First tags in the cache are being deleted.
852 (progn
853 (when semantic-edits-verbose-flag
854 (message "To Remove First Tag: (%s)"
855 (semantic-format-tag-name first)))
856 ;; Find the last tag
857 (setq cacheend chil)
858 (while (and cacheend (not (eq last (car cacheend))))
859 (setq cacheend (cdr cacheend)))
860 ;; The splicable part is after cacheend.. so move cacheend
861 ;; one more tag.
862 (setq cacheend (cdr cacheend))
863 ;; Splice the found end tag into the cons cell
864 ;; owned by the current top child.
865 (setcar chil (car cacheend))
866 (setcdr chil (cdr cacheend))
867 (when (not cacheend)
868 ;; No cacheend.. then the whole system is empty.
869 ;; The best way to deal with that is to do a full
870 ;; reparse
871 (semantic-parse-changes-failed "Splice-remove failed. Empty buffer?")
872 ))
873 (message "To Remove Middle Tag: (%s)"
874 (semantic-format-tag-name first)))
875 ;; Find in the cache the preceeding tag
876 (while (and cachestart (not (eq first (car (cdr cachestart)))))
877 (setq cachestart (cdr cachestart)))
878 ;; Find the last tag
879 (setq cacheend cachestart)
880 (while (and cacheend (not (eq last (car cacheend))))
881 (setq cacheend (cdr cacheend)))
882 ;; Splice the end position into the start position.
883 ;; If there is no start, then this whole section is probably
884 ;; gone.
885 (if cachestart
886 (setcdr cachestart (cdr cacheend))
887 (semantic-parse-changes-failed "Splice-remove failed."))
888
889 ;; Remove old overlays of these deleted tags
890 (while oldtags
891 (semantic--tag-unlink-from-buffer (car oldtags))
892 (setq oldtags (cdr oldtags)))
893 ))
894
895(defun semantic-edits-splice-insert (newtags parent cachelist)
896 "Insert NEWTAGS into PARENT using CACHELIST.
897PARENT could be nil, in which case CACHLIST is the buffer cache
898which must be updated.
899CACHELIST must be searched to find where NEWTAGS are to be inserted.
900The positions of NEWTAGS must be synchronized with those in
901CACHELIST for this to work. Some routines pre-position CACHLIST at a
902convenient location, so use that."
903 (let* ((start (semantic-tag-start (car newtags)))
904 (newtagendcell (nthcdr (1- (length newtags)) newtags))
905 (end (semantic-tag-end (car newtagendcell)))
906 )
907 (if (> (semantic-tag-start (car cachelist)) start)
908 ;; We are at the beginning.
909 (let* ((pc (if parent
910 (semantic-tag-components parent)
911 semantic--buffer-cache))
912 (nc (cons (car pc) (cdr pc))) ; new cons cell.
913 )
914 ;; Splice the new cache cons cell onto the end of our list.
915 (setcdr newtagendcell nc)
916 ;; Set our list into parent.
917 (setcar pc (car newtags))
918 (setcdr pc (cdr newtags)))
919 ;; We are at the end, or in the middle. Find our match first.
920 (while (and (cdr cachelist)
921 (> end (semantic-tag-start (car (cdr cachelist)))))
922 (setq cachelist (cdr cachelist)))
923 ;; Now splice into the list!
924 (setcdr newtagendcell (cdr cachelist))
925 (setcdr cachelist newtags))))
926
927(defun semantic-edits-splice-replace (oldtag newtag)
928 "Replace OLDTAG with NEWTAG in the current cache.
929Do this by recycling OLDTAG's first CONS cell. This effectivly
930causes the new tag to completely replace the old one.
931Make sure that all information in the overlay is transferred.
932It is presumed that OLDTAG and NEWTAG are both cooked.
933When this routine returns, OLDTAG is raw, and the data will be
934lost if not transferred into NEWTAG."
935 (let* ((oo (semantic-tag-overlay oldtag))
936 (o (semantic-tag-overlay newtag))
937 (oo-props (semantic-overlay-properties oo)))
938 (while oo-props
939 (semantic-overlay-put o (car oo-props) (car (cdr oo-props)))
940 (setq oo-props (cdr (cdr oo-props)))
941 )
942 ;; Free the old overlay(s)
943 (semantic--tag-unlink-from-buffer oldtag)
944 ;; Recover properties
945 (semantic--tag-copy-properties oldtag newtag)
946 ;; Splice into the main list.
947 (setcdr oldtag (cdr newtag))
948 (setcar oldtag (car newtag))
949 ;; This important bit is because the CONS cell representing
950 ;; OLDTAG is now pointing to NEWTAG, but the NEWTAG
951 ;; cell is about to be abandoned. Here we update our overlay
952 ;; to point at the updated state of the world.
953 (semantic-overlay-put o 'semantic oldtag)
954 ))
955
956;;; Setup incremental parser
957;;
958(add-hook 'semantic-change-hooks
959 #'semantic-edits-change-function-handle-changes)
960(add-hook 'semantic-before-toplevel-cache-flush-hook
961 #'semantic-edits-flush-changes)
962
963(provide 'semantic/edit)
964
965;;; semantic-edit.el ends here
diff --git a/lisp/cedet/semantic/html.el b/lisp/cedet/semantic/html.el
new file mode 100644
index 00000000000..05d1b2b7d8f
--- /dev/null
+++ b/lisp/cedet/semantic/html.el
@@ -0,0 +1,262 @@
1;;; html.el --- Semantic details for html files
2
3;;; Copyright (C) 2004, 2005, 2007, 2008 Free Software Foundation, Inc.
4
5;; Author: Eric M. Ludlam <zappo@gnu.org>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;
24;; Parse HTML files and organize them in a nice way.
25;; Pay attention to anchors, including them in the tag list.
26;;
27;; Copied from the original semantic-texi.el.
28;;
29;; ToDo: Find <script> tags, and parse the contents in other
30;; parsers, such as javascript, php, shtml, or others.
31
32(require 'semantic)
33(require 'semantic/format)
34(condition-case nil
35 ;; This is not installed in all versions of Emacs.
36 (require 'sgml-mode) ;; html-mode is in here.
37 (error
38 (require 'psgml-mode) ;; XEmacs uses psgml, and html-mode is in here.
39 ))
40
41;;; Code:
42(eval-when-compile
43 (require 'semantic/ctxt)
44 (require 'semantic/imenu)
45 (require 'senator))
46
47(defvar semantic-html-super-regex
48 "<\\(h[1-9]\\|title\\|script\\|body\\|a +href\\)\\>"
49 "Regular expression used to find special sections in an HTML file.")
50
51(defvar semantic-html-section-list
52 '(("title" 1)
53 ("script" 1)
54 ("body" 1)
55 ("a" 11)
56 ("h1" 2)
57 ("h2" 3)
58 ("h3" 4)
59 ("h4" 5)
60 ("h5" 6)
61 ("h6" 7)
62 ("h7" 8)
63 ("h8" 9)
64 ("h9" 10)
65 )
66 "Alist of sectioning commands and their relative level.")
67
68(define-mode-local-override semantic-parse-region
69 html-mode (&rest ignore)
70 "Parse the current html buffer for semantic tags.
71INGNORE any arguments. Always parse the whole buffer.
72Each tag returned is of the form:
73 (\"NAME\" section (:members CHILDREN))
74or
75 (\"NAME\" anchor)"
76 (mapcar 'semantic-html-expand-tag
77 (semantic-html-parse-headings)))
78
79(define-mode-local-override semantic-parse-changes
80 html-mode ()
81 "We can't parse changes for HTML mode right now."
82 (semantic-parse-tree-set-needs-rebuild))
83
84(defun semantic-html-expand-tag (tag)
85 "Expand the HTML tag TAG."
86 (let ((chil (semantic-html-components tag)))
87 (if chil
88 (semantic-tag-put-attribute
89 tag :members (mapcar 'semantic-html-expand-tag chil)))
90 (car (semantic--tag-expand tag))))
91
92(defun semantic-html-components (tag)
93 "Return components belonging to TAG."
94 (semantic-tag-get-attribute tag :members))
95
96(defun semantic-html-parse-headings ()
97 "Parse the current html buffer for all semantic tags."
98 (let ((pass1 nil))
99 ;; First search and snarf.
100 (save-excursion
101 (goto-char (point-min))
102
103 (let ((semantic--progress-reporter
104 (make-progress-reporter
105 (format "Parsing %s..."
106 (file-name-nondirectory buffer-file-name))
107 (point-min) (point-max))))
108 (while (re-search-forward semantic-html-super-regex nil t)
109 (setq pass1 (cons (match-beginning 0) pass1))
110 (progress-reporter-update semantic--progress-reporter (point)))
111 (progress-reporter-done semantic--progress-reporter)))
112
113 (setq pass1 (nreverse pass1))
114 ;; Now, make some tags while creating a set of children.
115 (car (semantic-html-recursive-combobulate-list pass1 0))
116 ))
117
118(defun semantic-html-set-endpoint (metataglist pnt)
119 "Set the end point of the first section tag in METATAGLIST to PNT.
120METATAGLIST is a list of tags in the intermediate tag format used by the
121html parser. PNT is the new point to set."
122 (let ((metatag nil))
123 (while (and metataglist
124 (not (eq (semantic-tag-class (car metataglist)) 'section)))
125 (setq metataglist (cdr metataglist)))
126 (setq metatag (car metataglist))
127 (when metatag
128 (setcar (nthcdr (1- (length metatag)) metatag) pnt)
129 metatag)))
130
131(defsubst semantic-html-new-section-tag (name members level start end)
132 "Create a semantic tag of class section.
133NAME is the name of this section.
134MEMBERS is a list of semantic tags representing the elements that make
135up this section.
136LEVEL is the levelling level.
137START and END define the location of data described by the tag."
138 (let ((anchorp (eq level 11)))
139 (append (semantic-tag name
140 (cond (anchorp 'anchor)
141 (t 'section))
142 :members members)
143 (list start (if anchorp (point) end)) )))
144
145(defun semantic-html-extract-section-name ()
146 "Extract a section name from the current buffer and point.
147Assume the cursor is in the tag representing the section we
148need the name from."
149 (save-excursion
150 ; Skip over the HTML tag.
151 (forward-sexp -1)
152 (forward-char -1)
153 (forward-sexp 1)
154 (skip-chars-forward "\n\t ")
155 (while (looking-at "<")
156 (forward-sexp 1)
157 (skip-chars-forward "\n\t ")
158 )
159 (let ((start (point))
160 (end nil))
161 (if (re-search-forward "</" nil t)
162 (progn
163 (goto-char (match-beginning 0))
164 (skip-chars-backward " \n\t")
165 (setq end (point))
166 (buffer-substring-no-properties start end))
167 ""))
168 ))
169
170(defun semantic-html-recursive-combobulate-list (sectionlist level)
171 "Rearrange SECTIONLIST to be a hierarchical tag list starting at LEVEL.
172Return the rearranged new list, with all remaining tags from
173SECTIONLIST starting at ELT 2. Sections not are not dealt with as soon as a
174tag with greater section value than LEVEL is found."
175 (let ((newl nil)
176 (oldl sectionlist)
177 (case-fold-search t)
178 tag
179 )
180 (save-excursion
181 (catch 'level-jump
182 (while oldl
183 (goto-char (car oldl))
184 (if (looking-at "<\\(\\w+\\)")
185 (let* ((word (match-string 1))
186 (levelmatch (assoc-ignore-case
187 word semantic-html-section-list))
188 text begin tmp
189 )
190 (when (not levelmatch)
191 (error "Tag %s matched in regexp but is not in list"
192 word))
193 ;; Set begin to the right location
194 (setq begin (point))
195 ;; Get out of here if there if we made it that far.
196 (if (and levelmatch (<= (car (cdr levelmatch)) level))
197 (progn
198 (when newl
199 (semantic-html-set-endpoint newl begin))
200 (throw 'level-jump t)))
201 ;; When there is a match, the descriptive text
202 ;; consists of the rest of the line.
203 (goto-char (match-end 1))
204 (skip-chars-forward " \t")
205 (setq text (semantic-html-extract-section-name))
206 ;; Next, recurse into the body to find the end.
207 (setq tmp (semantic-html-recursive-combobulate-list
208 (cdr oldl) (car (cdr levelmatch))))
209 ;; Build a tag
210 (setq tag (semantic-html-new-section-tag
211 text (car tmp) (car (cdr levelmatch)) begin (point-max)))
212 ;; Before appending the newtag, update the previous tag
213 ;; if it is a section tag.
214 (when newl
215 (semantic-html-set-endpoint newl begin))
216 ;; Append new tag to our master list.
217 (setq newl (cons tag newl))
218 ;; continue
219 (setq oldl (cdr tmp))
220 )
221 (error "Problem finding section in semantic/html parser"))
222 ;; (setq oldl (cdr oldl))
223 )))
224 ;; Return the list
225 (cons (nreverse newl) oldl)))
226
227(define-mode-local-override semantic-sb-tag-children-to-expand
228 html-mode (tag)
229 "The children TAG expands to."
230 (semantic-html-components tag))
231
232(defun semantic-default-html-setup ()
233 "Set up a buffer for parsing of HTML files."
234 ;; This will use our parser.
235 (setq semantic-parser-name "HTML"
236 semantic--parse-table t
237 imenu-create-index-function 'semantic-create-imenu-index
238 semantic-command-separation-character ">"
239 semantic-type-relation-separator-character '(":")
240 semantic-symbol->name-assoc-list '((section . "Section")
241
242 )
243 semantic-imenu-expandable-tag-classes '(section)
244 semantic-imenu-bucketize-file nil
245 semantic-imenu-bucketize-type-members nil
246 senator-step-at-start-end-tag-classes '(section)
247 semantic-stickyfunc-sticky-classes '(section)
248 )
249 (semantic-install-function-overrides
250 '((tag-components . semantic-html-components)
251 )
252 t)
253 )
254
255(add-hook 'html-mode-hook 'semantic-default-html-setup)
256
257(define-child-mode html-helper-mode html-mode
258 "`html-helper-mode' needs the same semantic support as `html-mode'.")
259
260(provide 'semantic/html)
261
262;;; semantic-html.el ends here
diff --git a/lisp/cedet/semantic/idle.el b/lisp/cedet/semantic/idle.el
new file mode 100644
index 00000000000..15dded40035
--- /dev/null
+++ b/lisp/cedet/semantic/idle.el
@@ -0,0 +1,957 @@
1;;; idle.el --- Schedule parsing tasks in idle time
2
3;;; Copyright (C) 2003, 2004, 2005, 2006, 2008, 2009
4;;; 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;; Originally, `semantic-auto-parse-mode' handled refreshing the
27;; tags in a buffer in idle time. Other activities can be scheduled
28;; in idle time, all of which require up-to-date tag tables.
29;; Having a specialized idle time scheduler that first refreshes
30;; the tags buffer, and then enables other idle time tasks reduces
31;; the amount of work needed. Any specialized idle tasks need not
32;; ask for a fresh tags list.
33;;
34;; NOTE ON SEMANTIC_ANALYZE
35;;
36;; Some of the idle modes use the semantic analyzer. The analyzer
37;; automatically caches the created context, so it is shared amongst
38;; all idle modes that will need it.
39
40(require 'semantic/util-modes)
41(require 'timer)
42
43;;; Code:
44
45;;; TIMER RELATED FUNCTIONS
46;;
47(defvar semantic-idle-scheduler-timer nil
48 "Timer used to schedule tasks in idle time.")
49
50(defvar semantic-idle-scheduler-work-timer nil
51 "Timer used to schedule tasks in idle time that may take a while.")
52
53(defcustom semantic-idle-scheduler-verbose-flag nil
54 "*Non-nil means that the idle scheduler should provide debug messages.
55Use this setting to debug idle activities."
56 :group 'semantic
57 :type 'boolean)
58
59(defcustom semantic-idle-scheduler-idle-time 2
60 "*Time in seconds of idle before scheduling events.
61This time should be short enough to ensure that idle-scheduler will be
62run as soon as Emacs is idle."
63 :group 'semantic
64 :type 'number
65 :set (lambda (sym val)
66 (set-default sym val)
67 (when (timerp semantic-idle-scheduler-timer)
68 (cancel-timer semantic-idle-scheduler-timer)
69 (setq semantic-idle-scheduler-timer nil)
70 (semantic-idle-scheduler-setup-timers))))
71
72(defcustom semantic-idle-scheduler-work-idle-time 60
73 "*Time in seconds of idle before scheduling big work.
74This time should be long enough that once any big work is started, it is
75unlikely the user would be ready to type again right away."
76 :group 'semantic
77 :type 'number
78 :set (lambda (sym val)
79 (set-default sym val)
80 (when (timerp semantic-idle-scheduler-timer)
81 (cancel-timer semantic-idle-scheduler-timer)
82 (setq semantic-idle-scheduler-timer nil)
83 (semantic-idle-scheduler-setup-timers))))
84
85(defun semantic-idle-scheduler-setup-timers ()
86 "Lazy initialization of the auto parse idle timer."
87 ;; REFRESH THIS FUNCTION for XEMACS FOIBLES
88 (or (timerp semantic-idle-scheduler-timer)
89 (setq semantic-idle-scheduler-timer
90 (run-with-idle-timer
91 semantic-idle-scheduler-idle-time t
92 #'semantic-idle-scheduler-function)))
93 (or (timerp semantic-idle-scheduler-work-timer)
94 (setq semantic-idle-scheduler-work-timer
95 (run-with-idle-timer
96 semantic-idle-scheduler-work-idle-time t
97 #'semantic-idle-scheduler-work-function)))
98 )
99
100(defun semantic-idle-scheduler-kill-timer ()
101 "Kill the auto parse idle timer."
102 (if (timerp semantic-idle-scheduler-timer)
103 (cancel-timer semantic-idle-scheduler-timer))
104 (setq semantic-idle-scheduler-timer nil))
105
106
107;;; MINOR MODE
108;;
109;; The minor mode portion of this code just sets up the minor mode
110;; which does the initial scheduling of the idle timers.
111;;
112(defcustom global-semantic-idle-scheduler-mode nil
113 "*If non-nil, enable global use of idle-scheduler mode."
114 :group 'semantic
115 :group 'semantic-modes
116 :type 'boolean
117 :require 'semantic/idle
118 :initialize 'custom-initialize-default
119 :set (lambda (sym val)
120 (global-semantic-idle-scheduler-mode (if val 1 -1))))
121
122;;;###autoload
123(defun global-semantic-idle-scheduler-mode (&optional arg)
124 "Toggle global use of option `semantic-idle-scheduler-mode'.
125The idle scheduler with automatically reparse buffers in idle time,
126and then schedule other jobs setup with `semantic-idle-scheduler-add'.
127If ARG is positive, enable, if it is negative, disable.
128If ARG is nil, then toggle."
129 (interactive "P")
130 (setq global-semantic-idle-scheduler-mode
131 (semantic-toggle-minor-mode-globally
132 'semantic-idle-scheduler-mode arg)))
133
134(defcustom semantic-idle-scheduler-mode-hook nil
135 "*Hook run at the end of function `semantic-idle-scheduler-mode'."
136 :group 'semantic
137 :type 'hook)
138
139;;;###autoload
140(defvar semantic-idle-scheduler-mode nil
141 "Non-nil if idle-scheduler minor mode is enabled.
142Use the command `semantic-idle-scheduler-mode' to change this variable.")
143(make-variable-buffer-local 'semantic-idle-scheduler-mode)
144
145(defcustom semantic-idle-scheduler-max-buffer-size 0
146 "*Maximum size in bytes of buffers where idle-scheduler is enabled.
147If this value is less than or equal to 0, idle-scheduler is enabled in
148all buffers regardless of their size."
149 :group 'semantic
150 :type 'number)
151
152(defsubst semantic-idle-scheduler-enabled-p ()
153 "Return non-nil if idle-scheduler is enabled for this buffer.
154idle-scheduler is disabled when debugging or if the buffer size
155exceeds the `semantic-idle-scheduler-max-buffer-size' threshold."
156 (and semantic-idle-scheduler-mode
157 (not semantic-debug-enabled)
158 (not semantic-lex-debug)
159 (or (<= semantic-idle-scheduler-max-buffer-size 0)
160 (< (buffer-size) semantic-idle-scheduler-max-buffer-size))))
161
162(defun semantic-idle-scheduler-mode-setup ()
163 "Setup option `semantic-idle-scheduler-mode'.
164The minor mode can be turned on only if semantic feature is available
165and the current buffer was set up for parsing. When minor mode is
166enabled parse the current buffer if needed. Return non-nil if the
167minor mode is enabled."
168 (if semantic-idle-scheduler-mode
169 (if (not (and (featurep 'semantic) (semantic-active-p)))
170 (progn
171 ;; Disable minor mode if semantic stuff not available
172 (setq semantic-idle-scheduler-mode nil)
173 (error "Buffer %s was not set up idle time scheduling"
174 (buffer-name)))
175 (semantic-idle-scheduler-setup-timers)))
176 semantic-idle-scheduler-mode)
177
178;;;###autoload
179(defun semantic-idle-scheduler-mode (&optional arg)
180 "Minor mode to auto parse buffer following a change.
181When this mode is off, a buffer is only rescanned for tokens when
182some command requests the list of available tokens. When idle-scheduler
183is enabled, Emacs periodically checks to see if the buffer is out of
184date, and reparses while the user is idle (not typing.)
185
186With prefix argument ARG, turn on if positive, otherwise off. The
187minor mode can be turned on only if semantic feature is available and
188the current buffer was set up for parsing. Return non-nil if the
189minor mode is enabled."
190 (interactive
191 (list (or current-prefix-arg
192 (if semantic-idle-scheduler-mode 0 1))))
193 (setq semantic-idle-scheduler-mode
194 (if arg
195 (>
196 (prefix-numeric-value arg)
197 0)
198 (not semantic-idle-scheduler-mode)))
199 (semantic-idle-scheduler-mode-setup)
200 (run-hooks 'semantic-idle-scheduler-mode-hook)
201 (if (interactive-p)
202 (message "idle-scheduler minor mode %sabled"
203 (if semantic-idle-scheduler-mode "en" "dis")))
204 (semantic-mode-line-update)
205 semantic-idle-scheduler-mode)
206
207(semantic-add-minor-mode 'semantic-idle-scheduler-mode
208 "ARP"
209 nil)
210
211(semantic-alias-obsolete 'semantic-auto-parse-mode
212 'semantic-idle-scheduler-mode)
213(semantic-alias-obsolete 'global-semantic-auto-parse-mode
214 'global-semantic-idle-scheduler-mode)
215
216
217;;; SERVICES services
218;;
219;; These are services for managing idle services.
220;;
221(defvar semantic-idle-scheduler-queue nil
222 "List of functions to execute during idle time.
223These functions will be called in the current buffer after that
224buffer has had its tags made up to date. These functions
225will not be called if there are errors parsing the
226current buffer.")
227
228;;;###autoload
229(defun semantic-idle-scheduler-add (function)
230 "Schedule FUNCTION to occur during idle time."
231 (add-to-list 'semantic-idle-scheduler-queue function))
232
233;;;###autoload
234(defun semantic-idle-scheduler-remove (function)
235 "Unschedule FUNCTION to occur during idle time."
236 (setq semantic-idle-scheduler-queue
237 (delete function semantic-idle-scheduler-queue)))
238
239;;; IDLE Function
240;;
241(defun semantic-idle-core-handler ()
242 "Core idle function that handles reparsing.
243And also manages services that depend on tag values."
244 (when semantic-idle-scheduler-verbose-flag
245 (message "IDLE: Core handler..."))
246 (semantic-exit-on-input 'idle-timer
247 (let* ((inhibit-quit nil)
248 (buffers (delq (current-buffer)
249 (delq nil
250 (mapcar #'(lambda (b)
251 (and (buffer-file-name b)
252 b))
253 (buffer-list)))))
254 safe ;; This safe is not used, but could be.
255 others
256 mode)
257 (when (semantic-idle-scheduler-enabled-p)
258 (save-excursion
259 ;; First, reparse the current buffer.
260 (setq mode major-mode
261 safe (semantic-safe "Idle Parse Error: %S"
262 ;(error "Goofy error 1")
263 (semantic-idle-scheduler-refresh-tags)
264 )
265 )
266 ;; Now loop over other buffers with same major mode, trying to
267 ;; update them as well. Stop on keypress.
268 (dolist (b buffers)
269 (semantic-throw-on-input 'parsing-mode-buffers)
270 (with-current-buffer b
271 (if (eq major-mode mode)
272 (and (semantic-idle-scheduler-enabled-p)
273 (semantic-safe "Idle Parse Error: %S"
274 ;(error "Goofy error")
275 (semantic-idle-scheduler-refresh-tags)))
276 (push (current-buffer) others))))
277 (setq buffers others))
278 ;; If re-parse of current buffer completed, evaluate all other
279 ;; services. Stop on keypress.
280
281 ;; NOTE ON COMMENTED SAFE HERE
282 ;; We used to not execute the services if the buffer wsa
283 ;; unparseable. We now assume that they are lexically
284 ;; safe to do, because we have marked the buffer unparseable
285 ;; if there was a problem.
286 ;;(when safe
287 (dolist (service semantic-idle-scheduler-queue)
288 (save-excursion
289 (semantic-throw-on-input 'idle-queue)
290 (when semantic-idle-scheduler-verbose-flag
291 (message "IDLE: execture service %s..." service))
292 (semantic-safe (format "Idle Service Error %s: %%S" service)
293 (funcall service))
294 (when semantic-idle-scheduler-verbose-flag
295 (message "IDLE: execture service %s...done" service))
296 )))
297 ;;)
298 ;; Finally loop over remaining buffers, trying to update them as
299 ;; well. Stop on keypress.
300 (save-excursion
301 (dolist (b buffers)
302 (semantic-throw-on-input 'parsing-other-buffers)
303 (with-current-buffer b
304 (and (semantic-idle-scheduler-enabled-p)
305 (semantic-idle-scheduler-refresh-tags)))))
306 ))
307 (when semantic-idle-scheduler-verbose-flag
308 (message "IDLE: Core handler...done")))
309
310(defun semantic-debug-idle-function ()
311 "Run the Semantic idle function with debugging turned on."
312 (interactive)
313 (let ((debug-on-error t))
314 (semantic-idle-core-handler)
315 ))
316
317(defun semantic-idle-scheduler-function ()
318 "Function run when after `semantic-idle-scheduler-idle-time'.
319This function will reparse the current buffer, and if successful,
320call additional functions registered with the timer calls."
321 (when (zerop (recursion-depth))
322 (let ((debug-on-error nil))
323 (save-match-data (semantic-idle-core-handler))
324 )))
325
326
327;;; WORK FUNCTION
328;;
329;; Unlike the shorter timer, the WORK timer will kick of tasks that
330;; may take a long time to complete.
331(defcustom semantic-idle-work-parse-neighboring-files-flag t
332 "*Non-nil means to parse files in the same dir as the current buffer.
333Disable to prevent lots of excessive parsing in idle time."
334 :group 'semantic
335 :type 'boolean)
336
337
338(defun semantic-idle-work-for-one-buffer (buffer)
339 "Do long-processing work for for BUFFER.
340Uses `semantic-safe' and returns the output.
341Returns t of all processing succeeded."
342 (save-excursion
343 (set-buffer buffer)
344 (not (and
345 ;; Just in case
346 (semantic-safe "Idle Work Parse Error: %S"
347 (semantic-idle-scheduler-refresh-tags)
348 t)
349
350 ;; Force all our include files to get read in so we
351 ;; are ready to provide good smart completion and idle
352 ;; summary information
353 (semantic-safe "Idle Work Including Error: %S"
354 ;; Get the include related path.
355 (when (and (featurep 'semantic/db)
356 (semanticdb-minor-mode-p))
357 (require 'semantic/db-find)
358 (semanticdb-find-translate-path buffer nil)
359 )
360 t)
361
362 ;; Pre-build the typecaches as needed.
363 (semantic-safe "Idle Work Typecaching Error: %S"
364 (when (featurep 'semantic/db-typecache)
365 (semanticdb-typecache-refresh-for-buffer buffer))
366 t)
367 ))
368 ))
369
370(defun semantic-idle-work-core-handler ()
371 "Core handler for idle work processing of long running tasks.
372Visits semantic controlled buffers, and makes sure all needed
373include files have been parsed, and that the typecache is up to date.
374Uses `semantic-idle-work-for-on-buffer' to do the work."
375 (let ((errbuf nil)
376 (interrupted
377 (semantic-exit-on-input 'idle-work-timer
378 (let* ((inhibit-quit nil)
379 (cb (current-buffer))
380 (buffers (delq (current-buffer)
381 (delq nil
382 (mapcar #'(lambda (b)
383 (and (buffer-file-name b)
384 b))
385 (buffer-list)))))
386 safe errbuf)
387 ;; First, handle long tasks in the current buffer.
388 (when (semantic-idle-scheduler-enabled-p)
389 (save-excursion
390 (setq safe (semantic-idle-work-for-one-buffer (current-buffer))
391 )))
392 (when (not safe) (push (current-buffer) errbuf))
393
394 ;; Now loop over other buffers with same major mode, trying to
395 ;; update them as well. Stop on keypress.
396 (dolist (b buffers)
397 (semantic-throw-on-input 'parsing-mode-buffers)
398 (with-current-buffer b
399 (when (semantic-idle-scheduler-enabled-p)
400 (and (semantic-idle-scheduler-enabled-p)
401 (unless (semantic-idle-work-for-one-buffer (current-buffer))
402 (push (current-buffer) errbuf)))
403 ))
404 )
405
406 ;; Save everything.
407 (semanticdb-save-all-db-idle)
408
409 ;; Parse up files near our active buffer
410 (when semantic-idle-work-parse-neighboring-files-flag
411 (semantic-safe "Idle Work Parse Neighboring Files: %S"
412 (when (and (featurep 'semantic/db)
413 (semanticdb-minor-mode-p))
414 (set-buffer cb)
415 (semantic-idle-scheduler-work-parse-neighboring-files))
416 t)
417 )
418
419 ;; Save everything... again
420 (semanticdb-save-all-db-idle)
421
422 ;; Done w/ processing
423 nil))))
424
425 ;; Done
426 (if interrupted
427 "Interrupted"
428 (cond ((not errbuf)
429 "done")
430 ((not (cdr errbuf))
431 (format "done with 1 error in %s" (car errbuf)))
432 (t
433 (format "done with errors in %d buffers."
434 (length errbuf)))))))
435
436(defun semantic-debug-idle-work-function ()
437 "Run the Semantic idle work function with debugging turned on."
438 (interactive)
439 (let ((debug-on-error t))
440 (semantic-idle-work-core-handler)
441 ))
442
443(defun semantic-idle-scheduler-work-function ()
444 "Function run when after `semantic-idle-scheduler-work-idle-time'.
445This routine handles difficult tasks that require a lot of parsing, such as
446parsing all the header files used by our active sources, or building up complex
447datasets."
448 (when semantic-idle-scheduler-verbose-flag
449 (message "Long Work Idle Timer..."))
450 (let ((exit-type (save-match-data
451 (semantic-idle-work-core-handler))))
452 (when semantic-idle-scheduler-verbose-flag
453 (message "Long Work Idle Timer...%s" exit-type)))
454 )
455
456(defun semantic-idle-scheduler-work-parse-neighboring-files ()
457 "Parse all the files in similar directories to buffers being edited."
458 ;; Lets check to see if EDE matters.
459 (let ((ede-auto-add-method 'never))
460 (dolist (a auto-mode-alist)
461 (when (eq (cdr a) major-mode)
462 (dolist (file (directory-files default-directory t (car a) t))
463 (semantic-throw-on-input 'parsing-mode-buffers)
464 (save-excursion
465 (semanticdb-file-table-object file)
466 ))))
467 ))
468
469(defun semantic-idle-pnf-test ()
470 "Test `semantic-idle-scheduler-work-parse-neighboring-files' and time it."
471 (interactive)
472 (let ((start (current-time))
473 (junk (semantic-idle-scheduler-work-parse-neighboring-files))
474 (end (current-time)))
475 (message "Work took %.2f seconds." (semantic-elapsed-time start end)))
476 )
477
478
479;;; REPARSING
480;;
481;; Reparsing is installed as semantic idle service.
482;; This part ALWAYS happens, and other services occur
483;; afterwards.
484
485;; (defcustom semantic-idle-scheduler-no-working-message t
486;; "*If non-nil, disable display of working messages during parse."
487;; :group 'semantic
488;; :type 'boolean)
489
490;; (defcustom semantic-idle-scheduler-working-in-modeline-flag nil
491;; "*Non-nil means show working messages in the mode line.
492;; Typically, parsing will show messages in the minibuffer.
493;; This will move the parse message into the modeline."
494;; :group 'semantic
495;; :type 'boolean)
496
497(defvar semantic-before-idle-scheduler-reparse-hooks nil
498 "Hooks run before option `semantic-idle-scheduler' begins parsing.
499If any hook throws an error, this variable is reset to nil.
500This hook is not protected from lexical errors.")
501
502(defvar semantic-after-idle-scheduler-reparse-hooks nil
503 "Hooks run after option `semantic-idle-scheduler' has parsed.
504If any hook throws an error, this variable is reset to nil.
505This hook is not protected from lexical errors.")
506
507(defun semantic-idle-scheduler-refresh-tags ()
508 "Refreshes the current buffer's tags.
509This is called by `semantic-idle-scheduler-function' to update the
510tags in the current buffer.
511
512Return non-nil if the refresh was successful.
513Return nil if there is some sort of syntax error preventing a full
514reparse.
515
516Does nothing if the current buffer doesn't need reparsing."
517
518 (prog1
519 ;; These checks actually occur in `semantic-fetch-tags', but if we
520 ;; do them here, then all the bovination hooks are not run, and
521 ;; we save lots of time.
522 (cond
523 ;; If the buffer was previously marked unparseable,
524 ;; then don't waste our time.
525 ((semantic-parse-tree-unparseable-p)
526 nil)
527 ;; The parse tree is already ok.
528 ((semantic-parse-tree-up-to-date-p)
529 t)
530 (t
531 ;; If the buffer might need a reparse and it is safe to do so,
532 ;; give it a try.
533 (let* (;(semantic-working-type nil)
534 (inhibit-quit nil)
535 ;; (working-use-echo-area-p
536 ;; (not semantic-idle-scheduler-working-in-modeline-flag))
537 ;; (working-status-dynamic-type
538 ;; (if semantic-idle-scheduler-no-working-message
539 ;; nil
540 ;; working-status-dynamic-type))
541 ;; (working-status-percentage-type
542 ;; (if semantic-idle-scheduler-no-working-message
543 ;; nil
544 ;; working-status-percentage-type))
545 (lexically-safe t)
546 )
547 ;; Let people hook into this, but don't let them hose
548 ;; us over!
549 (condition-case nil
550 (run-hooks 'semantic-before-idle-scheduler-reparse-hooks)
551 (error (setq semantic-before-idle-scheduler-reparse-hooks nil)))
552
553 (unwind-protect
554 ;; Perform the parsing.
555 (progn
556 (when semantic-idle-scheduler-verbose-flag
557 (message "IDLE: reparse %s..." (buffer-name)))
558 (when (semantic-lex-catch-errors idle-scheduler
559 (save-excursion (semantic-fetch-tags))
560 nil)
561 ;; If we are here, it is because the lexical step failed,
562 ;; proably due to unterminated lists or something like that.
563
564 ;; We do nothing, and just wait for the next idle timer
565 ;; to go off. In the meantime, remember this, and make sure
566 ;; no other idle services can get executed.
567 (setq lexically-safe nil))
568 (when semantic-idle-scheduler-verbose-flag
569 (message "IDLE: reparse %s...done" (buffer-name))))
570 ;; Let people hook into this, but don't let them hose
571 ;; us over!
572 (condition-case nil
573 (run-hooks 'semantic-after-idle-scheduler-reparse-hooks)
574 (error (setq semantic-after-idle-scheduler-reparse-hooks nil))))
575 ;; Return if we are lexically safe (from prog1)
576 lexically-safe)))
577
578 ;; After updating the tags, handle any pending decorations for this
579 ;; buffer.
580 (semantic-decorate-flush-pending-decorations (current-buffer))
581 ))
582
583
584;;; IDLE SERVICES
585;;
586;; Idle Services are minor modes which enable or disable a services in
587;; the idle scheduler. Creating a new services only requires calling
588;; `semantic-create-idle-services' which does all the setup
589;; needed to create the minor mode that will enable or disable
590;; a services. The services must provide a single function.
591
592(defmacro define-semantic-idle-service (name doc &rest forms)
593 "Create a new idle services with NAME.
594DOC will be a documentation string describing FORMS.
595FORMS will be called during idle time after the current buffer's
596semantic tag information has been updated.
597This routines creates the following functions and variables:"
598 (let ((global (intern (concat "global-" (symbol-name name) "-mode")))
599 (mode (intern (concat (symbol-name name) "-mode")))
600 (hook (intern (concat (symbol-name name) "-mode-hook")))
601 (map (intern (concat (symbol-name name) "-mode-map")))
602 (setup (intern (concat (symbol-name name) "-mode-setup")))
603 (func (intern (concat (symbol-name name) "-idle-function")))
604 )
605
606 `(eval-and-compile
607 (defun ,global (&optional arg)
608 ,(concat "Toggle global use of option `" (symbol-name mode) "'.
609If ARG is positive, enable, if it is negative, disable.
610If ARG is nil, then toggle.")
611 (interactive "P")
612 (setq ,global
613 (semantic-toggle-minor-mode-globally
614 ',mode arg)))
615
616 (defcustom ,global nil
617 (concat "*If non-nil, enable global use of `" (symbol-name ',mode) "'.
618" ,doc)
619 :group 'semantic
620 :group 'semantic-modes
621 :type 'boolean
622 :require 'semantic/idle
623 :initialize 'custom-initialize-default
624 :set (lambda (sym val)
625 (,global (if val 1 -1))))
626
627 (defcustom ,hook nil
628 (concat "*Hook run at the end of function `" (symbol-name ',mode) "'.")
629 :group 'semantic
630 :type 'hook)
631
632 (defvar ,map
633 (let ((km (make-sparse-keymap)))
634 km)
635 (concat "Keymap for `" (symbol-name ',mode) "'."))
636
637 (defvar ,mode nil
638 (concat "Non-nil if summary minor mode is enabled.
639Use the command `" (symbol-name ',mode) "' to change this variable."))
640 (make-variable-buffer-local ',mode)
641
642 (defun ,setup ()
643 ,(concat "Setup option `" (symbol-name mode) "'.
644The minor mode can be turned on only if semantic feature is available
645and the idle scheduler is active.
646Return non-nil if the minor mode is enabled.")
647 (if ,mode
648 (if (not (and (featurep 'semantic) (semantic-active-p)))
649 (progn
650 ;; Disable minor mode if semantic stuff not available
651 (setq ,mode nil)
652 (error "Buffer %s was not set up for parsing"
653 (buffer-name)))
654 ;; Enable the mode mode
655 (semantic-idle-scheduler-add #',func)
656 )
657 ;; Disable the mode mode
658 (semantic-idle-scheduler-remove #',func)
659 )
660 ,mode)
661
662;;;###autoload
663 (defun ,mode (&optional arg)
664 ,(concat doc "
665This is a minor mode which performs actions during idle time.
666With prefix argument ARG, turn on if positive, otherwise off. The
667minor mode can be turned on only if semantic feature is available and
668the current buffer was set up for parsing. Return non-nil if the
669minor mode is enabled.")
670 (interactive
671 (list (or current-prefix-arg
672 (if ,mode 0 1))))
673 (setq ,mode
674 (if arg
675 (>
676 (prefix-numeric-value arg)
677 0)
678 (not ,mode)))
679 (,setup)
680 (run-hooks ,hook)
681 (if (interactive-p)
682 (message "%s %sabled"
683 (symbol-name ',mode)
684 (if ,mode "en" "dis")))
685 (semantic-mode-line-update)
686 ,mode)
687
688 (semantic-add-minor-mode ',mode
689 "" ; idle schedulers are quiet?
690 ,map)
691
692 (defun ,func ()
693 ,doc
694 ,@forms)
695
696 )))
697(put 'define-semantic-idle-service 'lisp-indent-function 1)
698
699
700;;; SUMMARY MODE
701;;
702;; A mode similar to eldoc using semantic
703(require 'semantic/ctxt)
704
705(defcustom semantic-idle-summary-function
706 'semantic-format-tag-summarize-with-file
707 "*Function to use when displaying tag information during idle time.
708Some useful functions are found in `semantic-format-tag-functions'."
709 :group 'semantic
710 :type semantic-format-tag-custom-list)
711
712(defsubst semantic-idle-summary-find-current-symbol-tag (sym)
713 "Search for a semantic tag with name SYM in database tables.
714Return the tag found or nil if not found.
715If semanticdb is not in use, use the current buffer only."
716 (car (if (and (featurep 'semantic/db) semanticdb-current-database)
717 (cdar (semanticdb-deep-find-tags-by-name sym))
718 (semantic-deep-find-tags-by-name sym (current-buffer)))))
719
720(defun semantic-idle-summary-current-symbol-info-brutish ()
721 "Return a string message describing the current context.
722Gets a symbol with `semantic-ctxt-current-thing' and then
723trys to find it with a deep targetted search."
724 ;; Try the current "thing".
725 (let ((sym (car (semantic-ctxt-current-thing))))
726 (when sym
727 (semantic-idle-summary-find-current-symbol-tag sym))))
728
729(defun semantic-idle-summary-current-symbol-keyword ()
730 "Return a string message describing the current symbol.
731Returns a value only if it is a keyword."
732 ;; Try the current "thing".
733 (let ((sym (car (semantic-ctxt-current-thing))))
734 (if (and sym (semantic-lex-keyword-p sym))
735 (semantic-lex-keyword-get sym 'summary))))
736
737(defun semantic-idle-summary-current-symbol-info-context ()
738 "Return a string message describing the current context.
739Use the semantic analyzer to find the symbol information."
740 (let ((analysis (condition-case nil
741 (semantic-analyze-current-context (point))
742 (error nil))))
743 (when analysis
744 (semantic-analyze-interesting-tag analysis))))
745
746(defun semantic-idle-summary-current-symbol-info-default ()
747 "Return a string message describing the current context.
748This functin will disable loading of previously unloaded files
749by semanticdb as a time-saving measure."
750 (let (
751 (semanticdb-find-default-throttle
752 (if (featurep 'semantic/db-find)
753 (remq 'unloaded semanticdb-find-default-throttle)
754 nil))
755 )
756 (save-excursion
757 ;; use whicever has success first.
758 (or
759 (semantic-idle-summary-current-symbol-keyword)
760
761 (semantic-idle-summary-current-symbol-info-context)
762
763 (semantic-idle-summary-current-symbol-info-brutish)
764 ))))
765
766(defvar semantic-idle-summary-out-of-context-faces
767 '(
768 font-lock-comment-face
769 font-lock-string-face
770 font-lock-doc-string-face ; XEmacs.
771 font-lock-doc-face ; Emacs 21 and later.
772 )
773 "List of font-lock faces that indicate a useless summary context.
774Those are generally faces used to highlight comments.
775
776It might be useful to override this variable to add comment faces
777specific to a major mode. For example, in jde mode:
778
779\(defvar-mode-local jde-mode semantic-idle-summary-out-of-context-faces
780 (append (default-value 'semantic-idle-summary-out-of-context-faces)
781 '(jde-java-font-lock-doc-tag-face
782 jde-java-font-lock-link-face
783 jde-java-font-lock-bold-face
784 jde-java-font-lock-underline-face
785 jde-java-font-lock-pre-face
786 jde-java-font-lock-code-face)))")
787
788(defun semantic-idle-summary-useful-context-p ()
789 "Non-nil of we should show a summary based on context."
790 (if (and (boundp 'font-lock-mode)
791 font-lock-mode
792 (memq (get-text-property (point) 'face)
793 semantic-idle-summary-out-of-context-faces))
794 ;; The best I can think of at the moment is to disable
795 ;; in comments by detecting with font-lock.
796 nil
797 t))
798
799(define-overloadable-function semantic-idle-summary-current-symbol-info ()
800 "Return a string message describing the current context.")
801
802(make-obsolete-overload 'semantic-eldoc-current-symbol-info
803 'semantic-idle-summary-current-symbol-info)
804
805(define-semantic-idle-service semantic-idle-summary
806 "Display a tag summary of the lexical token under the cursor.
807Call `semantic-idle-summary-current-symbol-info' for getting the
808current tag to display information."
809 (or (eq major-mode 'emacs-lisp-mode)
810 (not (semantic-idle-summary-useful-context-p))
811 (let* ((found (semantic-idle-summary-current-symbol-info))
812 (str (cond ((stringp found) found)
813 ((semantic-tag-p found)
814 (funcall semantic-idle-summary-function
815 found nil t))))
816 )
817 ;; Show the message with eldoc functions
818 (require 'eldoc)
819 (unless (and str (boundp 'eldoc-echo-area-use-multiline-p)
820 eldoc-echo-area-use-multiline-p)
821 (let ((w (1- (window-width (minibuffer-window)))))
822 (if (> (length str) w)
823 (setq str (substring str 0 w)))))
824 (eldoc-message str))))
825
826(semantic-alias-obsolete 'semantic-summary-mode
827 'semantic-idle-summary-mode)
828(semantic-alias-obsolete 'global-semantic-summary-mode
829 'global-semantic-idle-summary-mode)
830
831;;; Current symbol highlight
832;;
833;; This mode will use context analysis to perform highlighting
834;; of all uses of the symbol that is under the cursor.
835;;
836;; This is to mimic the Eclipse tool of a similar nature.
837(defvar semantic-idle-summary-highlight-face 'region
838 "Face used for the summary highlight.")
839
840(defun semantic-idle-summary-maybe-highlight (tag)
841 "Perhaps add highlighting onto TAG.
842TAG was found as the thing under point. If it happens to be
843visible, then highlight it."
844 (let* ((region (when (and (semantic-tag-p tag)
845 (semantic-tag-with-position-p tag))
846 (semantic-tag-overlay tag)))
847 (file (when (and (semantic-tag-p tag)
848 (semantic-tag-with-position-p tag))
849 (semantic-tag-file-name tag)))
850 (buffer (when file (get-file-buffer file)))
851 ;; We use pulse, but we don't want the flashy version,
852 ;; just the stable version.
853 (pulse-flag nil)
854 )
855 (cond ((semantic-overlay-p region)
856 (save-excursion
857 (set-buffer (semantic-overlay-buffer region))
858 (goto-char (semantic-overlay-start region))
859 (when (pos-visible-in-window-p
860 (point) (get-buffer-window (current-buffer) 'visible))
861 (if (< (semantic-overlay-end region) (point-at-eol))
862 (pulse-momentary-highlight-overlay
863 region semantic-idle-summary-highlight-face)
864 ;; Not the same
865 (pulse-momentary-highlight-region
866 (semantic-overlay-start region)
867 (point-at-eol)
868 semantic-idle-summary-highlight-face)))
869 ))
870 ((vectorp region)
871 (let ((start (aref region 0))
872 (end (aref region 1)))
873 (save-excursion
874 (when buffer (set-buffer buffer))
875 ;; As a vector, we have no filename. Perhaps it is a
876 ;; local variable?
877 (when (and (<= end (point-max))
878 (pos-visible-in-window-p
879 start (get-buffer-window (current-buffer) 'visible)))
880 (goto-char start)
881 (when (re-search-forward
882 (regexp-quote (semantic-tag-name tag))
883 end t)
884 ;; This is likely it, give it a try.
885 (pulse-momentary-highlight-region
886 start (if (<= end (point-at-eol)) end
887 (point-at-eol))
888 semantic-idle-summary-highlight-face)))
889 ))))
890 nil))
891
892(define-semantic-idle-service semantic-idle-tag-highlight
893 "Highlight the tag, and references of the symbol under point.
894Call `semantic-analyze-current-context' to find the reference tag.
895Call `semantic-symref-hits-in-region' to identify local references."
896 (when (semantic-idle-summary-useful-context-p)
897 (let* ((ctxt (semantic-analyze-current-context))
898 (Hbounds (when ctxt (oref ctxt bounds)))
899 (target (when ctxt (car (reverse (oref ctxt prefix)))))
900 (tag (semantic-current-tag))
901 ;; We use pulse, but we don't want the flashy version,
902 ;; just the stable version.
903 (pulse-flag nil))
904 (when ctxt
905 ;; Highlight the original tag? Protect against problems.
906 (condition-case nil
907 (semantic-idle-summary-maybe-highlight target)
908 (error nil))
909 ;; Identify all hits in this current tag.
910 (when (semantic-tag-p target)
911 (semantic-symref-hits-in-region
912 target (lambda (start end prefix)
913 (when (/= start (car Hbounds))
914 (pulse-momentary-highlight-region
915 start end))
916 (semantic-throw-on-input 'symref-highlight)
917 )
918 (semantic-tag-start tag)
919 (semantic-tag-end tag)))
920 ))))
921
922
923;;; Completion Popup Mode
924;;
925;; This mode uses tooltips to display a (hopefully) short list of possible
926;; completions available for the text under point. It provides
927;; NO provision for actually filling in the values from those completions.
928
929(defun semantic-idle-completion-list-default ()
930 "Calculate and display a list of completions."
931 (when (semantic-idle-summary-useful-context-p)
932 ;; This mode can be fragile. Ignore problems.
933 ;; If something doesn't do what you expect, run
934 ;; the below command by hand instead.
935 (condition-case nil
936 (let (
937 ;; Don't go loading in oodles of header libraries in
938 ;; IDLE time.
939 (semanticdb-find-default-throttle
940 (if (featurep 'semantic/db-find)
941 (remq 'unloaded semanticdb-find-default-throttle)
942 nil))
943 )
944 ;; Use idle version.
945 (semantic-complete-analyze-inline-idle)
946 )
947 (error nil))
948 ))
949
950(define-semantic-idle-service semantic-idle-completions
951 "Display a list of possible completions in a tooltip."
952 ;; Add the ability to override sometime.
953 (semantic-idle-completion-list-default))
954
955(provide 'semantic/idle)
956
957;;; semantic-idle.el ends here
diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el
index c9029a3e98b..9768a1e992c 100644
--- a/lisp/cedet/semantic/lex.el
+++ b/lisp/cedet/semantic/lex.el
@@ -315,6 +315,42 @@ PROPERTY set."
315 #'(lambda (symbol) (setq keywords (cons symbol keywords))) 315 #'(lambda (symbol) (setq keywords (cons symbol keywords)))
316 property) 316 property)
317 keywords)) 317 keywords))
318
319;;; Inline functions:
320
321(defvar semantic-lex-unterminated-syntax-end-function)
322(defvar semantic-lex-analysis-bounds)
323(defvar semantic-lex-end-point)
324
325(defsubst semantic-lex-token-bounds (token)
326 "Fetch the start and end locations of the lexical token TOKEN.
327Return a pair (START . END)."
328 (if (not (numberp (car (cdr token))))
329 (cdr (cdr token))
330 (cdr token)))
331
332(defsubst semantic-lex-token-start (token)
333 "Fetch the start position of the lexical token TOKEN.
334See also the function `semantic-lex-token'."
335 (car (semantic-lex-token-bounds token)))
336
337(defsubst semantic-lex-token-end (token)
338 "Fetch the end position of the lexical token TOKEN.
339See also the function `semantic-lex-token'."
340 (cdr (semantic-lex-token-bounds token)))
341
342(defsubst semantic-lex-unterminated-syntax-detected (syntax)
343 "Inside a lexical analyzer, use this when unterminated syntax was found.
344Argument SYNTAX indicates the type of syntax that is unterminated.
345The job of this function is to move (point) to a new logical location
346so that analysis can continue, if possible."
347 (goto-char
348 (funcall semantic-lex-unterminated-syntax-end-function
349 syntax
350 (car semantic-lex-analysis-bounds)
351 (cdr semantic-lex-analysis-bounds)
352 ))
353 (setq semantic-lex-end-point (point)))
318 354
319;;; Type table handling. 355;;; Type table handling.
320;; 356;;
@@ -1012,23 +1048,6 @@ variable after calling `semantic-lex-push-token'."
1012See also the function `semantic-lex-token'." 1048See also the function `semantic-lex-token'."
1013 (car token)) 1049 (car token))
1014 1050
1015(defsubst semantic-lex-token-bounds (token)
1016 "Fetch the start and end locations of the lexical token TOKEN.
1017Return a pair (START . END)."
1018 (if (not (numberp (car (cdr token))))
1019 (cdr (cdr token))
1020 (cdr token)))
1021
1022(defsubst semantic-lex-token-start (token)
1023 "Fetch the start position of the lexical token TOKEN.
1024See also the function `semantic-lex-token'."
1025 (car (semantic-lex-token-bounds token)))
1026
1027(defsubst semantic-lex-token-end (token)
1028 "Fetch the end position of the lexical token TOKEN.
1029See also the function `semantic-lex-token'."
1030 (cdr (semantic-lex-token-bounds token)))
1031
1032(defsubst semantic-lex-token-text (token) 1051(defsubst semantic-lex-token-text (token)
1033 "Fetch the text associated with the lexical token TOKEN. 1052 "Fetch the text associated with the lexical token TOKEN.
1034See also the function `semantic-lex-token'." 1053See also the function `semantic-lex-token'."
@@ -1084,19 +1103,6 @@ Optional argument DEPTH is the depth to scan into lists."
1084;; Created analyzers become variables with the code associated with them 1103;; Created analyzers become variables with the code associated with them
1085;; as the symbol value. These analyzers are assembled into a lexer 1104;; as the symbol value. These analyzers are assembled into a lexer
1086;; to create new lexical analyzers. 1105;; to create new lexical analyzers.
1087;;
1088(defsubst semantic-lex-unterminated-syntax-detected (syntax)
1089 "Inside a lexical analyzer, use this when unterminated syntax was found.
1090Argument SYNTAX indicates the type of syntax that is unterminated.
1091The job of this function is to move (point) to a new logical location
1092so that analysis can continue, if possible."
1093 (goto-char
1094 (funcall semantic-lex-unterminated-syntax-end-function
1095 syntax
1096 (car semantic-lex-analysis-bounds)
1097 (cdr semantic-lex-analysis-bounds)
1098 ))
1099 (setq semantic-lex-end-point (point)))
1100 1106
1101(defcustom semantic-lex-debug-analyzers nil 1107(defcustom semantic-lex-debug-analyzers nil
1102 "Non nil means to debug analyzers with syntax protection. 1108 "Non nil means to debug analyzers with syntax protection.
diff --git a/lisp/cedet/semantic/texi.el b/lisp/cedet/semantic/texi.el
new file mode 100644
index 00000000000..1115ef7e051
--- /dev/null
+++ b/lisp/cedet/semantic/texi.el
@@ -0,0 +1,677 @@
1;;; texi.el --- Semantic details for Texinfo files
2
3;;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009
4;;; Free Software Foundation, Inc.
5
6;; Author: Eric M. Ludlam <zappo@gnu.org>
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24;;
25;; Parse Texinfo buffers using regular expressions. The core parser
26;; engine is the function `semantic-texi-parse-headings'. The
27;; parser plug-in is the function `semantic-texi-parse-region' that
28;; overrides `semantic-parse-region'.
29
30(require 'semantic)
31(require 'semantic/format)
32(require 'texinfo)
33
34(eval-when-compile
35 (require 'semantic/db)
36 (require 'semantic/db-find)
37 (require 'semantic/ctxt)
38 (require 'semantic/imenu)
39 (require 'semantic/doc)
40 (require 'senator))
41
42(defvar semantic-texi-super-regex
43 "^@\\(top\\|chapter\\|\\(sub\\)*section\\|unnumbered\\(\\(sub\\)*sec\\)?\\|\
44\\(chap\\|\\(sub\\)+\\|major\\)?heading\\|appendix\\(\\(sub\\)*sec\\)?\\|\
45centerchap\\|def\\(var\\|un\\|fn\\|opt\\)x?\\)"
46 "Regular expression used to find special sections in a Texinfo file.")
47
48(defvar semantic-texi-name-field-list
49 '( ("defvar" . 1)
50 ("defvarx" . 1)
51 ("defun" . 1)
52 ("defunx" . 1)
53 ("defopt" . 1)
54 ("deffn" . 2)
55 ("deffnx" . 2)
56 )
57 "List of definition commands, and the field position.
58The field position is the field number (based at 1) where the
59name of this section is.")
60
61;;; Code:
62(defun semantic-texi-parse-region (&rest ignore)
63 "Parse the current texinfo buffer for semantic tags.
64IGNORE any arguments, always parse the whole buffer.
65Each tag returned is of the form:
66 (\"NAME\" section (:members CHILDREN))
67or
68 (\"NAME\" def)
69
70It is an override of 'parse-region and must be installed by the
71function `semantic-install-function-overrides'."
72 (mapcar 'semantic-texi-expand-tag
73 (semantic-texi-parse-headings)))
74
75(defun semantic-texi-parse-changes ()
76 "Parse changes in the current texinfo buffer."
77 ;; NOTE: For now, just schedule a full reparse.
78 ;; To be implemented later.
79 (semantic-parse-tree-set-needs-rebuild))
80
81(defun semantic-texi-expand-tag (tag)
82 "Expand the texinfo tag TAG."
83 (let ((chil (semantic-tag-components tag)))
84 (if chil
85 (semantic-tag-put-attribute
86 tag :members (mapcar 'semantic-texi-expand-tag chil)))
87 (car (semantic--tag-expand tag))))
88
89(defun semantic-texi-parse-headings ()
90 "Parse the current texinfo buffer for all semantic tags now."
91 (let ((pass1 nil))
92 ;; First search and snarf.
93 (save-excursion
94 (goto-char (point-min))
95 (let ((semantic--progress-reporter
96 (make-progress-reporter
97 (format "Parsing %s..."
98 (file-name-nondirectory buffer-file-name))
99 (point-min) (point-max))))
100 (while (re-search-forward semantic-texi-super-regex nil t)
101 (setq pass1 (cons (match-beginning 0) pass1))
102 (progress-reporter-update semantic--progress-reporter (point)))
103 (progress-reporter-done semantic--progress-reporter)))
104 (setq pass1 (nreverse pass1))
105 ;; Now, make some tags while creating a set of children.
106 (car (semantic-texi-recursive-combobulate-list pass1 0))
107 ))
108
109(defsubst semantic-texi-new-section-tag (name members start end)
110 "Create a semantic tag of class section.
111NAME is the name of this section.
112MEMBERS is a list of semantic tags representing the elements that make
113up this section.
114START and END define the location of data described by the tag."
115 (append (semantic-tag name 'section :members members)
116 (list start end)))
117
118(defsubst semantic-texi-new-def-tag (name start end)
119 "Create a semantic tag of class def.
120NAME is the name of this definition.
121START and END define the location of data described by the tag."
122 (append (semantic-tag name 'def)
123 (list start end)))
124
125(defun semantic-texi-set-endpoint (metataglist pnt)
126 "Set the end point of the first section tag in METATAGLIST to PNT.
127METATAGLIST is a list of tags in the intermediate tag format used by the
128texinfo parser. PNT is the new point to set."
129 (let ((metatag nil))
130 (while (and metataglist
131 (not (eq (semantic-tag-class (car metataglist)) 'section)))
132 (setq metataglist (cdr metataglist)))
133 (setq metatag (car metataglist))
134 (when metatag
135 (setcar (nthcdr (1- (length metatag)) metatag) pnt)
136 metatag)))
137
138(defun semantic-texi-recursive-combobulate-list (sectionlist level)
139 "Rearrange SECTIONLIST to be a hierarchical tag list starting at LEVEL.
140Return the rearranged new list, with all remaining tags from
141SECTIONLIST starting at ELT 2. Sections not are not dealt with as soon as a
142tag with greater section value than LEVEL is found."
143 (let ((newl nil)
144 (oldl sectionlist)
145 tag
146 )
147 (save-excursion
148 (catch 'level-jump
149 (while oldl
150 (goto-char (car oldl))
151 (if (looking-at "@\\(\\w+\\)")
152 (let* ((word (match-string 1))
153 (levelmatch (assoc word texinfo-section-list))
154 text begin tmp
155 )
156 ;; Set begin to the right location
157 (setq begin (point))
158 ;; Get out of here if there if we made it that far.
159 (if (and levelmatch (<= (car (cdr levelmatch)) level))
160 (progn
161 (when newl
162 (semantic-texi-set-endpoint newl begin))
163 (throw 'level-jump t)))
164 ;; Recombobulate
165 (if levelmatch
166 (let ((end (match-end 1)))
167 ;; Levels sometimes have a @node just in front.
168 ;; That node statement should be included in the space
169 ;; for this entry.
170 (save-excursion
171 (skip-chars-backward "\n \t")
172 (beginning-of-line)
173 (when (looking-at "@node\\>")
174 (setq begin (point))))
175 ;; When there is a match, the descriptive text
176 ;; consists of the rest of the line.
177 (goto-char end)
178 (skip-chars-forward " \t")
179 (setq text (buffer-substring-no-properties
180 (point)
181 (progn (end-of-line) (point))))
182 ;; Next, recurse into the body to find the end.
183 (setq tmp (semantic-texi-recursive-combobulate-list
184 (cdr oldl) (car (cdr levelmatch))))
185 ;; Build a tag
186 (setq tag (semantic-texi-new-section-tag
187 text (car tmp) begin (point)))
188 ;; Before appending the newtag, update the previous tag
189 ;; if it is a section tag.
190 (when newl
191 (semantic-texi-set-endpoint newl begin))
192 ;; Append new tag to our master list.
193 (setq newl (cons tag newl))
194 ;; continue
195 (setq oldl (cdr tmp))
196 )
197 ;; No match means we have a def*, so get the name from
198 ;; it based on the type of thingy we found.
199 (setq levelmatch (assoc word semantic-texi-name-field-list)
200 tmp (or (cdr levelmatch) 1))
201 (forward-sexp tmp)
202 (skip-chars-forward " \t")
203 (setq text (buffer-substring-no-properties
204 (point)
205 (progn (forward-sexp 1) (point))))
206 ;; Seek the end of this definition
207 (goto-char begin)
208 (semantic-texi-forward-deffn)
209 (setq tag (semantic-texi-new-def-tag text begin (point))
210 newl (cons tag newl))
211 ;; continue
212 (setq oldl (cdr oldl)))
213 )
214 (error "Problem finding section in semantic/texi parser"))
215 ;; (setq oldl (cdr oldl))
216 )
217 ;; When oldl runs out, force a new endpoint as point-max
218 (when (not oldl)
219 (semantic-texi-set-endpoint newl (point-max)))
220 ))
221 (cons (nreverse newl) oldl)))
222
223(defun semantic-texi-forward-deffn ()
224 "Move forward over one deffn type definition.
225The cursor should be on the @ sign."
226 (when (looking-at "@\\(\\w+\\)")
227 (let* ((type (match-string 1))
228 (seek (concat "^@end\\s-+" (regexp-quote type))))
229 (re-search-forward seek nil t))))
230
231(define-mode-local-override semantic-tag-components
232 texinfo-mode (tag)
233 "Return components belonging to TAG."
234 (semantic-tag-get-attribute tag :members))
235
236
237;;; Overrides: Context Parsing
238;;
239;; How to treat texi as a language?
240;;
241(defvar semantic-texi-environment-regexp
242 (if (string-match texinfo-environment-regexp "@menu")
243 ;; Make sure our Emacs has menus in it.
244 texinfo-environment-regexp
245 ;; If no menus, then merge in the menu concept.
246 (when (string-match "cartouche" texinfo-environment-regexp)
247 (concat (substring texinfo-environment-regexp
248 0 (match-beginning 0))
249 "menu\\|"
250 (substring texinfo-environment-regexp
251 (match-beginning 0)))))
252 "Regular expression for matching texinfo enviroments.
253uses `texinfo-environment-regexp', but makes sure that it
254can handle the @menu environment.")
255
256(define-mode-local-override semantic-up-context texinfo-mode ()
257 "Handle texinfo constructs which do not use parenthetical nesting."
258 (let ((done nil))
259 (save-excursion
260 (let ((parenthetical (semantic-up-context-default))
261 )
262 (when (not parenthetical)
263 ;; We are in parenthises. Are they the types of parens
264 ;; belonging to a texinfo construct?
265 (forward-word -1)
266 (when (looking-at "@\\w+{")
267 (setq done (point))))))
268 ;; If we are not in a parenthetical node, then find a block instead.
269 ;; Use the texinfo support to find block start/end constructs.
270 (save-excursion
271 (while (and (not done)
272 (re-search-backward semantic-texi-environment-regexp nil t))
273 ;; For any hit, if we find an @end foo, then jump to the
274 ;; matching @foo. If it is not an end, then we win!
275 (if (not (looking-at "@end\\s-+\\(\\w+\\)"))
276 (setq done (point))
277 ;; Skip over this block
278 (let ((env (match-string 1)))
279 (re-search-backward (concat "@" env))))
280 ))
281 ;; All over, post what we find.
282 (if done
283 ;; We found something, so use it.
284 (progn (goto-char done)
285 nil)
286 t)))
287
288(define-mode-local-override semantic-beginning-of-context texinfo-mode (&optional point)
289 "Move to the beginning of the context surrounding POINT."
290 (if (semantic-up-context point)
291 ;; If we can't go up, we can't do this either.
292 t
293 ;; We moved, so now we need to skip into whatever this thing is.
294 (forward-word 1) ;; skip the command
295 (if (looking-at "\\s-*{")
296 ;; In a short command. Go in.
297 (down-list 1)
298 ;; An environment. Go to the next line.
299 (end-of-line)
300 (forward-char 1))
301 nil))
302
303(define-mode-local-override semantic-ctxt-current-class-list
304 texinfo-mode (&optional point)
305 "Determine the class of tags that can be used at POINT.
306For texinfo, there two possibilities returned.
3071) 'function - for a call to a texinfo function
3082) 'word - indicates an english word.
309It would be nice to know function arguments too, but not today."
310 (let ((sym (semantic-ctxt-current-symbol)))
311 (if (and sym (= (aref (car sym) 0) ?@))
312 '(function)
313 '(word))))
314
315
316;;; Overrides : Formatting
317;;
318;; Various override to better format texi tags.
319;;
320
321(define-mode-local-override semantic-format-tag-abbreviate
322 texinfo-mode (tag &optional parent color)
323 "Texinfo tags abbreviation."
324 (let ((class (semantic-tag-class tag))
325 (name (semantic-format-tag-name tag parent color))
326 )
327 (cond ((eq class 'function)
328 (concat name "{ }"))
329 (t (semantic-format-tag-abbreviate-default tag parent color)))
330 ))
331
332(define-mode-local-override semantic-format-tag-prototype
333 texinfo-mode (tag &optional parent color)
334 "Texinfo tags abbreviation."
335 (semantic-format-tag-abbreviate tag parent color))
336
337
338;;; Texi Unique Features
339;;
340(defun semantic-tag-texi-section-text-bounds (tag)
341 "Get the bounds to the text of TAG.
342The text bounds is the text belonging to this node excluding
343the text of any child nodes, but including any defuns."
344 (let ((memb (semantic-tag-components tag)))
345 ;; Members.. if one is a section, check it out.
346 (while (and memb (not (semantic-tag-of-class-p (car memb) 'section)))
347 (setq memb (cdr memb)))
348 ;; No members? ... then a simple problem!
349 (if (not memb)
350 (semantic-tag-bounds tag)
351 ;; Our end is their beginning...
352 (list (semantic-tag-start tag) (semantic-tag-start (car memb))))))
353
354(defun semantic-texi-current-environment (&optional point)
355 "Return as a string the type of the current environment.
356Optional argument POINT is where to look for the environment."
357 (save-excursion
358 (when point (goto-char (point)))
359 (while (and (or (not (looking-at semantic-texi-environment-regexp))
360 (looking-at "@end"))
361 (not (semantic-up-context)))
362 )
363 (when (looking-at semantic-texi-environment-regexp)
364 (match-string 1))))
365
366
367;;; Analyzer
368;;
369(eval-when-compile
370 (require 'semantic/analyze))
371
372(define-mode-local-override semantic-analyze-current-context
373 texinfo-mode (point)
374 "Analysis context makes no sense for texinfo. Return nil."
375 (let* ((prefixandbounds (semantic-ctxt-current-symbol-and-bounds (point)))
376 (prefix (car prefixandbounds))
377 (bounds (nth 2 prefixandbounds))
378 (prefixclass (semantic-ctxt-current-class-list))
379 )
380 (when prefix
381 (require 'semantic-analyze)
382 (semantic-analyze-context
383 "Context-for-texinfo"
384 :buffer (current-buffer)
385 :scope nil
386 :bounds bounds
387 :prefix prefix
388 :prefixtypes nil
389 :prefixclass prefixclass)
390 )
391 ))
392
393(defvar semantic-texi-command-completion-list
394 (append (mapcar (lambda (a) (car a)) texinfo-section-list)
395 (condition-case nil
396 texinfo-environments
397 (error
398 ;; XEmacs doesn't use the above. Split up its regexp
399 (split-string texinfo-environment-regexp "\\\\|\\|\\^@\\\\(\\|\\\\)")
400 ))
401 ;; Is there a better list somewhere? Here are few
402 ;; of the top of my head.
403 "anchor" "asis"
404 "bullet"
405 "code" "copyright"
406 "defun" "deffn" "defoption" "defvar" "dfn"
407 "emph" "end"
408 "ifinfo" "iftex" "inforef" "item" "itemx"
409 "kdb"
410 "node"
411 "ref"
412 "set" "setfilename" "settitle"
413 "value" "var"
414 "xref"
415 )
416 "List of commands that we might bother completing.")
417
418(define-mode-local-override semantic-analyze-possible-completions
419 texinfo-mode (context)
420 "List smart completions at point.
421Since texinfo is not a programming language the default version is not
422useful. Insted, look at the current symbol. If it is a command
423do primitive texinfo built ins. If not, use ispell to lookup words
424that start with that symbol."
425 (let ((prefix (car (oref context :prefix)))
426 )
427 (cond ((member 'function (oref context :prefixclass))
428 ;; Do completion for texinfo commands
429 (let* ((cmd (substring prefix 1))
430 (lst (all-completions
431 cmd semantic-texi-command-completion-list)))
432 (mapcar (lambda (f) (semantic-tag (concat "@" f) 'function))
433 lst))
434 )
435 ((member 'word (oref context :prefixclass))
436 ;; Do completion for words via ispell.
437 (require 'ispell)
438 (let ((word-list (lookup-words prefix)))
439 (mapcar (lambda (f) (semantic-tag f 'word)) word-list))
440 )
441 (t nil))
442 ))
443
444
445;;; Parser Setup
446;;
447(defun semantic-default-texi-setup ()
448 "Set up a buffer for parsing of Texinfo files."
449 ;; This will use our parser.
450 (semantic-install-function-overrides
451 '((parse-region . semantic-texi-parse-region)
452 (parse-changes . semantic-texi-parse-changes)))
453 (setq semantic-parser-name "TEXI"
454 ;; Setup a dummy parser table to enable parsing!
455 semantic--parse-table t
456 imenu-create-index-function 'semantic-create-imenu-index
457 semantic-command-separation-character "@"
458 semantic-type-relation-separator-character '(":")
459 semantic-symbol->name-assoc-list '((section . "Section")
460 (def . "Definition")
461 )
462 semantic-imenu-expandable-tag-classes '(section)
463 semantic-imenu-bucketize-file nil
464 semantic-imenu-bucketize-type-members nil
465 senator-step-at-start-end-tag-classes '(section)
466 semantic-stickyfunc-sticky-classes '(section)
467 )
468 (local-set-key [(f9)] 'semantic-texi-update-doc-from-texi)
469 )
470
471(add-hook 'texinfo-mode-hook 'semantic-default-texi-setup)
472
473
474;;; Special features of Texinfo tag streams
475;;
476;; This section provides specialized access into texinfo files.
477;; Because texinfo files often directly refer to functions and programs
478;; it is useful to access the texinfo file from the C code for document
479;; maintainance.
480(defun semantic-texi-associated-files (&optional buffer)
481 "Find texinfo files associated with BUFFER."
482 (save-excursion
483 (if buffer (set-buffer buffer))
484 (cond ((and (fboundp 'ede-documentation-files)
485 ede-minor-mode (ede-current-project))
486 ;; When EDE is active, ask it.
487 (ede-documentation-files)
488 )
489 ((and (featurep 'semanticdb) (semanticdb-minor-mode-p))
490 ;; See what texinfo files we have loaded in the database
491 (let ((tabs (semanticdb-get-database-tables
492 semanticdb-current-database))
493 (r nil))
494 (while tabs
495 (if (eq (oref (car tabs) major-mode) 'texinfo-mode)
496 (setq r (cons (oref (car tabs) file) r)))
497 (setq tabs (cdr tabs)))
498 r))
499 (t
500 (directory-files default-directory nil "\\.texi$"))
501 )))
502
503;; Turns out this might not be useful.
504;; Delete later if that is true.
505(defun semantic-texi-find-documentation (name &optional type)
506 "Find the function or variable NAME of TYPE in the texinfo source.
507NAME is a string representing some functional symbol.
508TYPE is a string, such as \"variable\" or \"Command\" used to find
509the correct definition in case NAME qualifies as several things.
510When this function exists, POINT is at the definition.
511If the doc was not found, an error is thrown.
512Note: TYPE not yet implemented."
513 (let ((f (semantic-texi-associated-files))
514 stream match)
515 (while (and f (not match))
516 (unless stream
517 (with-current-buffer (find-file-noselect (car f))
518 (setq stream (semantic-fetch-tags))))
519 (setq match (semantic-find-first-tag-by-name name stream))
520 (when match
521 (set-buffer (semantic-tag-buffer match))
522 (goto-char (semantic-tag-start match)))
523 (setq f (cdr f)))))
524
525(defun semantic-texi-update-doc-from-texi (&optional tag)
526 "Update the documentation in the texinfo deffn class tag TAG.
527The current buffer must be a texinfo file containing TAG.
528If TAG is nil, determine a tag based on the current position."
529 (interactive)
530 (unless (or (featurep 'semanticdb) (semanticdb-minor-mode-p))
531 (error "Texinfo updating only works when `semanticdb' is being used"))
532 (semantic-fetch-tags)
533 (unless tag
534 (beginning-of-line)
535 (setq tag (semantic-current-tag)))
536 (unless (semantic-tag-of-class-p tag 'def)
537 (error "Only deffns (or defun or defvar) can be updated"))
538 (let* ((name (semantic-tag-name tag))
539 (tags (semanticdb-strip-find-results
540 (semanticdb-with-match-any-mode
541 (semanticdb-brute-deep-find-tags-by-name name))
542 'name))
543 (docstring nil)
544 (docstringproto nil)
545 (docstringvar nil)
546 (doctag nil)
547 (doctagproto nil)
548 (doctagvar nil)
549 )
550 (save-excursion
551 (while (and tags (not docstring))
552 (let ((sourcetag (car tags)))
553 ;; There could be more than one! Come up with a better
554 ;; solution someday.
555 (when (semantic-tag-buffer sourcetag)
556 (set-buffer (semantic-tag-buffer sourcetag))
557 (unless (eq major-mode 'texinfo-mode)
558 (cond ((semantic-tag-get-attribute sourcetag :prototype-flag)
559 ;; If we found a match with doc that is a prototype, then store
560 ;; that, but don't exit till we find the real deal.
561 (setq docstringproto (semantic-documentation-for-tag sourcetag)
562 doctagproto sourcetag))
563 ((eq (semantic-tag-class sourcetag) 'variable)
564 (setq docstringvar (semantic-documentation-for-tag sourcetag)
565 doctagvar sourcetag))
566 ((semantic-tag-get-attribute sourcetag :override-function-flag)
567 nil)
568 (t
569 (setq docstring (semantic-documentation-for-tag sourcetag))))
570 (setq doctag (if docstring sourcetag nil))))
571 (setq tags (cdr tags)))))
572 ;; If we found a prototype of the function that has some doc, but not the
573 ;; actual function, lets make due with that.
574 (if (not docstring)
575 (cond ((stringp docstringvar)
576 (setq docstring docstringvar
577 doctag doctagvar))
578 ((stringp docstringproto)
579 (setq docstring docstringproto
580 doctag doctagproto))))
581 ;; Test for doc string
582 (unless docstring
583 (error "Could not find documentation for %s" (semantic-tag-name tag)))
584 ;; If we have a string, do the replacement.
585 (delete-region (semantic-tag-start tag)
586 (semantic-tag-end tag))
587 ;; Use useful functions from the docaument library.
588 (require 'document)
589 (document-insert-texinfo doctag (semantic-tag-buffer doctag))
590 ))
591
592(defun semantic-texi-update-doc-from-source (&optional tag)
593 "Update the documentation for the source TAG.
594The current buffer must be a non-texinfo source file containing TAG.
595If TAG is nil, determine the tag based on the current position.
596The current buffer must include TAG."
597 (interactive)
598 (when (eq major-mode 'texinfo-mode)
599 (error "Not a source file"))
600 (semantic-fetch-tags)
601 (unless tag
602 (setq tag (semantic-current-tag)))
603 (unless (semantic-documentation-for-tag tag)
604 (error "Cannot find interesting documentation to use for %s"
605 (semantic-tag-name tag)))
606 (let* ((name (semantic-tag-name tag))
607 (texi (semantic-texi-associated-files))
608 (doctag nil)
609 (docbuff nil))
610 (while (and texi (not doctag))
611 (set-buffer (find-file-noselect (car texi)))
612 (setq doctag (car (semantic-deep-find-tags-by-name
613 name (semantic-fetch-tags)))
614 docbuff (if doctag (current-buffer) nil))
615 (setq texi (cdr texi)))
616 (unless doctag
617 (error "Tag %s is not yet documented. Use the `document' command"
618 name))
619 ;; Ok, we should have everything we need. Do the deed.
620 (if (get-buffer-window docbuff)
621 (set-buffer docbuff)
622 (switch-to-buffer docbuff))
623 (goto-char (semantic-tag-start doctag))
624 (delete-region (semantic-tag-start doctag)
625 (semantic-tag-end doctag))
626 ;; Use useful functions from the document library.
627 (require 'document)
628 (document-insert-texinfo tag (semantic-tag-buffer tag))
629 ))
630
631(defun semantic-texi-update-doc (&optional tag)
632 "Update the documentation for TAG.
633If the current buffer is a texinfo file, then find the source doc, and
634update it. If the current buffer is a source file, then get the
635documentation for this item, find the existing doc in the associated
636manual, and update that."
637 (interactive)
638 (cond ((eq major-mode 'texinfo-mode)
639 (semantic-texi-update-doc-from-texi tag))
640 (t
641 (semantic-texi-update-doc-from-source tag))))
642
643(defun semantic-texi-goto-source (&optional tag)
644 "Jump to the source for the definition in the texinfo file TAG.
645If TAG is nil, it is derived from the deffn under POINT."
646 (interactive)
647 (unless (or (featurep 'semanticdb) (semanticdb-minor-mode-p))
648 (error "Texinfo updating only works when `semanticdb' is being used"))
649 (semantic-fetch-tags)
650 (unless tag
651 (beginning-of-line)
652 (setq tag (semantic-current-tag)))
653 (unless (semantic-tag-of-class-p tag 'def)
654 (error "Only deffns (or defun or defvar) can be updated"))
655 (let* ((name (semantic-tag-name tag))
656 (tags (semanticdb-fast-strip-find-results
657 (semanticdb-with-match-any-mode
658 (semanticdb-brute-deep-find-tags-by-name name nil 'name))
659 ))
660
661 (done nil)
662 )
663 (save-excursion
664 (while (and tags (not done))
665 (set-buffer (semantic-tag-buffer (car tags)))
666 (unless (eq major-mode 'texinfo-mode)
667 (switch-to-buffer (semantic-tag-buffer (car tags)))
668 (goto-char (semantic-tag-start (car tags)))
669 (setq done t))
670 (setq tags (cdr tags)))
671 (if (not done)
672 (error "Could not find tag for %s" (semantic-tag-name tag)))
673 )))
674
675(provide 'semantic/texi)
676
677;;; semantic-texi.el ends here