diff options
| author | Chong Yidong | 2009-08-29 19:00:35 +0000 |
|---|---|---|
| committer | Chong Yidong | 2009-08-29 19:00:35 +0000 |
| commit | 9573e58b233ac4210a2801b1263f39843d4e48a0 (patch) | |
| tree | de2cb65f9b29559ce32b9c68d32ec4a44da70d23 | |
| parent | a175a831d33f56cce1793a7593fb14178118b117 (diff) | |
| download | emacs-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.el | 769 | ||||
| -rw-r--r-- | lisp/cedet/semantic/complete.el | 2128 | ||||
| -rw-r--r-- | lisp/cedet/semantic/edit.el | 965 | ||||
| -rw-r--r-- | lisp/cedet/semantic/html.el | 262 | ||||
| -rw-r--r-- | lisp/cedet/semantic/idle.el | 957 | ||||
| -rw-r--r-- | lisp/cedet/semantic/lex.el | 66 | ||||
| -rw-r--r-- | lisp/cedet/semantic/texi.el | 677 |
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. | ||
| 87 | Argument 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. | ||
| 100 | Usually 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. | ||
| 104 | This can be nil, or a list where the last element can be a string | ||
| 105 | representing text that may be incomplete. Preceeding elements | ||
| 106 | must be semantic tags representing variables or functions | ||
| 107 | called in a dereference sequence.") | ||
| 108 | (prefixclass :initarg :prefixclass | ||
| 109 | :type list | ||
| 110 | :documentation "Tag classes expected at this context. | ||
| 111 | These 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. | ||
| 115 | This list is one shorter than :prefix. Each element is a semantic | ||
| 116 | tag representing a type matching the semantic tag in the same | ||
| 117 | position in PREFIX.") | ||
| 118 | (scope :initarg :scope | ||
| 119 | :type (or null semantic-scope-cache) | ||
| 120 | :documentation "List of tags available in scopetype. | ||
| 121 | See `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. | ||
| 134 | This is a variable into which some value is being placed. The last | ||
| 135 | item in the list is the variable accepting the value. Earlier | ||
| 136 | tags represent the variables being derefernece to get to the | ||
| 137 | assignee.")) | ||
| 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. | ||
| 144 | This is a function being called. The cursor will be in the position | ||
| 145 | of an argument. | ||
| 146 | The last tag in :function is the function being called. Earlier | ||
| 147 | tags represent the variables being dereferenced to get to the | ||
| 148 | function.") | ||
| 149 | (index :initarg :index | ||
| 150 | :type integer | ||
| 151 | :documentation "The index of the argument for this context. | ||
| 152 | If a function takes 4 arguments, this value should be bound to | ||
| 153 | the values 1 through 4.") | ||
| 154 | (argument :initarg :argument | ||
| 155 | :type list | ||
| 156 | :documentation "A sequence of tags for the :index argument. | ||
| 157 | The argument can accept a value of some type, and this contains the | ||
| 158 | tag for that definition. It should be a tag, but might | ||
| 159 | be 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. | ||
| 166 | Return data methods identify the requred type by the return value | ||
| 167 | of 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. | ||
| 176 | Optional 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. | ||
| 234 | Optional argument LOCALVAR is the list of local variables to use when | ||
| 235 | finding the details on the first element of SEQUENCE in case | ||
| 236 | it is not found in the global set of tables. | ||
| 237 | Optional argument SCOPE are additional terminals to search which are currently | ||
| 238 | scoped. These are not local variables, but symbols available in a structure | ||
| 239 | which doesn't need to be dereferneced. | ||
| 240 | Optional argument TYPERETURN is a symbol in which the types of all found | ||
| 241 | will be stored. If nil, that data is thrown away. | ||
| 242 | Optional 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. | ||
| 248 | SCOPE are extra tags which are in scope. | ||
| 249 | TYPERETURN is a symbol in which to place a list of tag classes that | ||
| 250 | are found in SEQUENCE. | ||
| 251 | Optional 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. | ||
| 349 | Optional argument TAGCLASS specifies the class of tag to return, such | ||
| 350 | as 'function or 'variable. | ||
| 351 | Optional argument SCOPE specifies a scope object which has | ||
| 352 | additional tags which are in SCOPE and do not need prefixing to | ||
| 353 | find. | ||
| 354 | |||
| 355 | This is a wrapper on top of semanticdb, semanticdb-typecache, | ||
| 356 | semantic-scope, and semantic search functions. Almost all | ||
| 357 | searches 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. | ||
| 406 | The ANALYZEHOOKFCN is called with the current symbol bounds, and the | ||
| 407 | analyzed prefix. It should take the arguments (START END PREFIX). | ||
| 408 | The ANALYZEHOOKFCN is only called if some sort of prefix with bounds was | ||
| 409 | found under POSITION. | ||
| 410 | |||
| 411 | The results of ANALYZEHOOKFCN is returned, or nil if there was nothing to | ||
| 412 | call it with. | ||
| 413 | |||
| 414 | For regular analysis, you should call `semantic-analyze-current-context' | ||
| 415 | to calculate the context information. The purpose for this function is | ||
| 416 | to 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. | ||
| 475 | If called interactively, display interesting information about POSITION | ||
| 476 | in a separate buffer. | ||
| 477 | Returns an object based on symbol `semantic-analyze-context'. | ||
| 478 | |||
| 479 | This function can be overriden with the symbol `analyze-context'. | ||
| 480 | When overriding this function, your override will be called while | ||
| 481 | cursor is at POSITION. In addition, your function will not be called | ||
| 482 | if 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. | ||
| 517 | Returns 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. | ||
| 697 | Some 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. | ||
| 703 | Use PREFIX as a label. | ||
| 704 | Use 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. | ||
| 752 | CONTEXT'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. | ||
| 155 | For a minibuffer prompt, this is the minibuffer text. | ||
| 156 | For inline completion, this is the text wrapped in the inline completion | ||
| 157 | overlay." | ||
| 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. | ||
| 164 | Presumably 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. | ||
| 180 | Value 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. | ||
| 185 | Value 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. | ||
| 203 | Keeps 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. | ||
| 210 | Argument COLLECTOR is an object which can be used to to calculate | ||
| 211 | a list of possible hits. See `semantic-completion-collector-engine' | ||
| 212 | for details on COLLECTOR. | ||
| 213 | Argumeng DISPLAYOR is an object used to display a list of possible | ||
| 214 | completions for a given prefix. See`semantic-completion-display-engine' | ||
| 215 | for details on DISPLAYOR. | ||
| 216 | PROMPT is a string to prompt with. | ||
| 217 | DEFAULT-TAG is a semantic tag or string to use as the default value. | ||
| 218 | If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. | ||
| 219 | HISTORY 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. | ||
| 330 | Save this in our completion variable. Make sure that variable | ||
| 331 | is cleared if any other keypress is made. | ||
| 332 | Return 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. | ||
| 433 | ORIGINAL is the text in the minibuffer. | ||
| 434 | NEW is the new text to insert into the minibuffer. | ||
| 435 | Within the difference bounds of ORIGINAL and NEW, shorten NEW | ||
| 436 | to 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. | ||
| 452 | If 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. | ||
| 500 | If PARTIAL, do partial completion stopping at spaces. | ||
| 501 | if 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. | ||
| 574 | The 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. | ||
| 579 | Similar 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. | ||
| 662 | When installed as a `pre-command-hook' the special keymap | ||
| 663 | `semantic-complete-inline-map' is queried to replace commands normally run. | ||
| 664 | Commands which edit what is in the region of interest operate normally. | ||
| 665 | Commands which would take us out of the region of interest, or our | ||
| 666 | quit 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. | ||
| 676 | If completion mode is active, check to see if we are within | ||
| 677 | the bounds of `semantic-complete-inline-overlay', or within | ||
| 678 | a 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. | ||
| 725 | DO 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. | ||
| 746 | Argument COLLECTOR is an object which can be used to to calculate | ||
| 747 | a list of possible hits. See `semantic-completion-collector-engine' | ||
| 748 | for details on COLLECTOR. | ||
| 749 | Argumeng DISPLAYOR is an object used to display a list of possible | ||
| 750 | completions for a given prefix. See`semantic-completion-display-engine' | ||
| 751 | for details on DISPLAYOR. | ||
| 752 | BUFFER is the buffer in which completion will take place. | ||
| 753 | START is a location for the start of the full symbol. | ||
| 754 | If the symbol being completed is \"foo.ba\", then START | ||
| 755 | is on the \"f\" character. | ||
| 756 | END 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. | ||
| 815 | PARTIAL is non-nil if we are doing partial completion. | ||
| 816 | First, the collector can determine if we should perform a completion or not. | ||
| 817 | If there is nothing to complete, then the displayor determines if we are | ||
| 818 | to show a completion list, scroll, or perhaps do a focus (if it is capable.) | ||
| 819 | Expected 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. | ||
| 878 | Some collectors use a given buffer as a starting place while looking up | ||
| 879 | tags.") | ||
| 880 | (cache :initform nil | ||
| 881 | :type (or null semanticdb-find-result-with-nil) | ||
| 882 | :documentation "Cache of tags. | ||
| 883 | These tags are re-used during a completion session. | ||
| 884 | Sometimes 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'. | ||
| 888 | This result can be used for refined completions as `last-prefix' gets | ||
| 889 | closer to a specific result.") | ||
| 890 | (last-prefix :type string | ||
| 891 | :protection :protected | ||
| 892 | :documentation "The last queried prefix. | ||
| 893 | This prefix can be used to cache intermediate completion offers. | ||
| 894 | making the action of homing in on a token faster.") | ||
| 895 | (last-completion :type (or null string) | ||
| 896 | :documentation "The last calculated completion. | ||
| 897 | This completion is calculated and saved for future use.") | ||
| 898 | (last-whitespace-completion :type (or null string) | ||
| 899 | :documentation "The last whitespace completion. | ||
| 900 | For partial completion, SPC will disabiguate over whitespace type | ||
| 901 | characters. This is the last calculated version.") | ||
| 902 | (current-exact-match :type list | ||
| 903 | :protection :protected | ||
| 904 | :documentation "The list of matched tags. | ||
| 905 | When tokens are matched, they are added to this list.") | ||
| 906 | ) | ||
| 907 | "Root class for completion engines. | ||
| 908 | The baseclass provides basic functionality for interacting with | ||
| 909 | a completion displayor object, and tracking the current progress | ||
| 910 | of 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. | ||
| 920 | PARTIAL 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. | ||
| 950 | Calculate 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. | ||
| 957 | Output 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. | ||
| 1034 | This implies that if there are two completions, one matching | ||
| 1035 | the test \"preifx\\>\", and one not, the one matching the full | ||
| 1036 | word version of PREFIX will be chosen, and that text returned. | ||
| 1037 | This function requires that `semantic-collector-calculate-completions' | ||
| 1038 | has 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. | ||
| 1065 | For now, just return the first element from our list of available | ||
| 1066 | matches. For semanticdb based results, make sure the file is loaded | ||
| 1067 | into 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. | ||
| 1078 | For now, just return the first element from our list of available | ||
| 1079 | matches. For semanticdb based results, make sure the file is loaded | ||
| 1080 | into 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. | ||
| 1087 | The returned list consists of all the tags currently | ||
| 1088 | matching 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. | ||
| 1095 | See `try-completion' for details on how this works. | ||
| 1096 | Return nil for no match. | ||
| 1097 | Return a string for a partial match. | ||
| 1098 | For a unique match of PREFIX, return the list of all tags | ||
| 1099 | with 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. | ||
| 1123 | These 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. | ||
| 1146 | NEWCACHE 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. | ||
| 1163 | When searching for a tag, uses semantic deep searche functions. | ||
| 1164 | Basics 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. | ||
| 1169 | Uses `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. | ||
| 1183 | At 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. | ||
| 1187 | Uses 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. | ||
| 1215 | Specifies some context location from whence completion lists will be drawn." | ||
| 1216 | ) | ||
| 1217 | (first-pass-completions :type list | ||
| 1218 | :documentation "List of valid completion tags. | ||
| 1219 | This list of tags is generated when completion starts. All searches | ||
| 1220 | derive from this list.") | ||
| 1221 | ) | ||
| 1222 | "Completion engine that uses the context analyzer to provide options. | ||
| 1223 | The only options available for completion are those which can be logically | ||
| 1224 | inserted 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. | ||
| 1274 | Manages the display of some number of tags. | ||
| 1275 | Provides the basics for a displayor, including interacting with | ||
| 1276 | a 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. | ||
| 1319 | This 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. | ||
| 1332 | Traditional display mechanism for a list of possible completions. | ||
| 1333 | Completions are showin in a new buffer and listed with the ability | ||
| 1334 | to 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. | ||
| 1353 | Multiple calls to the display function can choose to focus on a | ||
| 1354 | given 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'. | ||
| 1362 | A displayor which has the ability to focus in on one tag. | ||
| 1363 | Focusing is a way of differentiationg between multiple tags | ||
| 1364 | which 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. | ||
| 1391 | Not 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. | ||
| 1403 | Not 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. | ||
| 1444 | A traditional displayor which can focus on a tag by showing it. | ||
| 1445 | Same as `semantic-displayor-traditional', but with selection between | ||
| 1446 | multiple tags with the same name done by 'focusing' on the source | ||
| 1447 | location 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. | ||
| 1452 | Focus is performed by cycling through the tags and highlighting | ||
| 1453 | one 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. | ||
| 1524 | If `force-show' is 1, this value is ignored with typing tab or space twice continuously. | ||
| 1525 | if `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. | ||
| 1541 | 0 means the tags are always shown. | ||
| 1542 | 1 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. | ||
| 1553 | Display 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. | ||
| 1629 | Return 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. | ||
| 1674 | Completion displayor using ghost chars after point for focus options. | ||
| 1675 | Whichever completion is currently in focus will be displayed as ghost | ||
| 1676 | text 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. | ||
| 1723 | Focus is performed by cycling through the tags and showing a possible | ||
| 1724 | completion 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. | ||
| 1767 | Available tags are from the current buffer, at any level. | ||
| 1768 | Completion options are presented in a traditional way, with highlighting | ||
| 1769 | to resolve same-name collisions. | ||
| 1770 | PROMPT is a string to prompt with. | ||
| 1771 | DEFAULT-TAG is a semantic tag or string to use as the default value. | ||
| 1772 | If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. | ||
| 1773 | HISTORY 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. | ||
| 1789 | Available tags are from the current project, at the top level. | ||
| 1790 | Completion options are presented in a traditional way, with highlighting | ||
| 1791 | to resolve same-name collisions. | ||
| 1792 | PROMPT is a string to prompt with. | ||
| 1793 | DEFAULT-TAG is a semantic tag or string to use as the default value. | ||
| 1794 | If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. | ||
| 1795 | HISTORY 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. | ||
| 1810 | This is similar to `semantic-complete-read-tag-project', except | ||
| 1811 | that the completion interaction is in the buffer where the context | ||
| 1812 | was calculated from. | ||
| 1813 | Customize `semantic-complete-inline-analyzer-displayor-class' | ||
| 1814 | to control how completion options are displayed. | ||
| 1815 | See `semantic-complete-inline-tag-engine' for details on how | ||
| 1816 | completion 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. | ||
| 1859 | The function `semantic-analyze-current-context' is used to | ||
| 1860 | calculate the context. `semantic-analyze-possible-completions' is used | ||
| 1861 | to generate the list of possible completions. | ||
| 1862 | PROMPT is the first part of the prompt. Additional prompt | ||
| 1863 | is added based on the contexts full prefix. | ||
| 1864 | CONTEXT is the semantic analyzer context to start with. | ||
| 1865 | HISTORY is a symbol representing a variable to stor the history in. | ||
| 1866 | usually a default-tag and initial-input are available for completion | ||
| 1867 | prompts. 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. | ||
| 1902 | Use 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. | ||
| 1914 | This is similar to `semantic-complete-read-tag-analyze', except | ||
| 1915 | that the completion interaction is in the buffer where the context | ||
| 1916 | was calculated from. | ||
| 1917 | CONTEXT is the semantic analyzer context to start with. | ||
| 1918 | Customize `semantic-complete-inline-analyzer-displayor-class' | ||
| 1919 | to control how completion options are displayed. | ||
| 1920 | |||
| 1921 | See `semantic-complete-inline-tag-engine' for details on how | ||
| 1922 | completion 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. | ||
| 1971 | CONTEXT is the semantic analyzer context to start with. | ||
| 1972 | This function is used from `semantic-idle-completions-mode'. | ||
| 1973 | |||
| 1974 | This is the same as `semantic-complete-inline-analyzer', except that | ||
| 1975 | it uses `semantic-complete-inline-analyzer-idle-displayor-class' | ||
| 1976 | to control how completions are displayed. | ||
| 1977 | |||
| 1978 | See `semantic-complete-inline-tag-engine' for details on how | ||
| 1979 | completion 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 | ||
| 2025 | possible values. | ||
| 2026 | The minibuffer is used to perform the completion. | ||
| 2027 | The 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 | ||
| 2040 | possible values. | ||
| 2041 | The function returns immediately, leaving the buffer in a mode that | ||
| 2042 | will perform the completion. | ||
| 2043 | Configure `semantic-complete-inline-analyzer-displayor-class' to change | ||
| 2044 | how 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 | ||
| 2062 | possible values. | ||
| 2063 | The function returns immediately, leaving the buffer in a mode that | ||
| 2064 | will perform the completion. | ||
| 2065 | Configure `semantic-complete-inline-analyzer-idle-displayor-class' | ||
| 2066 | to 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. | ||
| 2080 | ARG is passed to `self-insert-command'. If ARG is nil, | ||
| 2081 | use `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 | |||
| 68 | This hook will run when the cache has been partially reparsed. | ||
| 69 | Partial reparses are incurred when a user edits a buffer, and only the | ||
| 70 | modified sections are rescanned. | ||
| 71 | |||
| 72 | Hook functions must take one argument, which is the list of tags | ||
| 73 | updated in the current buffer. | ||
| 74 | |||
| 75 | For 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. | ||
| 79 | Each hook function must take three arguments, identical to the | ||
| 80 | common 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. | ||
| 84 | For language specific hooks, make sure you define this as a local | ||
| 85 | hook. | ||
| 86 | Not 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. | ||
| 90 | If the hook returns non-nil, then declare that a reparse is needed. | ||
| 91 | For language specific hooks, make sure you define this as a local | ||
| 92 | hook. | ||
| 93 | Not 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. | ||
| 97 | Functions 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. | ||
| 101 | Deleted changes occur when multiple changes are merged. | ||
| 102 | Functions 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. | ||
| 106 | Changes move when a new change overlaps an old change. The old change | ||
| 107 | will be moved. | ||
| 108 | Functions 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. | ||
| 112 | Functions are called before the overlay is deleted, and after the | ||
| 113 | incremental reparse.") | ||
| 114 | |||
| 115 | (defvar semantic-edits-incremental-reparse-failed-hooks nil | ||
| 116 | "Hooks run after the incremental parser fails. | ||
| 117 | When 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. | ||
| 121 | If 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. | ||
| 131 | Argument 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. | ||
| 140 | Optional 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. | ||
| 155 | Tracks when and how the buffer is re-parsed. | ||
| 156 | Argument 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. | ||
| 215 | HITS is the list of tags that CHANGE is in. It can have more than | ||
| 216 | one 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. | ||
| 248 | If change overlaps a tag, but is not encompassed in it, return nil. | ||
| 249 | Use `semantic-edits-change-overlap-leaf-tag'. | ||
| 250 | If CHANGE is completely encompassed in a tag, but overlaps sub-tags, | ||
| 251 | return 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. | ||
| 283 | The returned list is the CONS cell in the master list pointing to | ||
| 284 | a tag just before CHANGE. The CDR will have the tag just after CHANGE. | ||
| 285 | CHANGE cannot encompass or overlap a leaf tag. | ||
| 286 | If CHANGE is fully encompassed in a tag that has children, and | ||
| 287 | this change occurs between those children, this returns non-nil. | ||
| 288 | See `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. | ||
| 334 | CHANGE must not only include all overlapped tags (excepting possible | ||
| 335 | parent tags) in their entirety. In this case, the change may be deleting | ||
| 336 | or moving whole tags. | ||
| 337 | The return value is a vector. | ||
| 338 | Cell 0 is a list of all tags completely encompassed in change. | ||
| 339 | Cell 1 is the cons cell into a master parser cache starting with | ||
| 340 | the cell which occurs BEFORE the first position of CHANGE. | ||
| 341 | Cell 2 is the parent of cell 1, or nil for the buffer cache. | ||
| 342 | This function returns nil if any tag covered by change is not | ||
| 343 | completely encompassed. | ||
| 344 | See `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. | ||
| 456 | That is, display a message by passing all ARGS to `format', then throw | ||
| 457 | a '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. | ||
| 474 | Incremental parser allows semantic to only reparse those sections of | ||
| 475 | the buffer that have changed. This function depends on | ||
| 476 | `semantic-edits-change-function-handle-changes' setting up change | ||
| 477 | overlays in the current buffer. Those overlays are analyzed against | ||
| 478 | the 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. | ||
| 507 | Return the list of tags that changed. | ||
| 508 | If the incremental parse fails, throw a 'semantic-parse-changes-failed | ||
| 509 | exception with value t, that can be caught to schedule a full reparse. | ||
| 510 | This 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. | ||
| 836 | OLDTAGS are tags in the currenet buffer, preferably linked | ||
| 837 | together also in CACHELIST. | ||
| 838 | PARENT is the parent tag containing OLDTAGS. | ||
| 839 | CACHELIST should be the children from PARENT, but may be | ||
| 840 | pre-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. | ||
| 897 | PARENT could be nil, in which case CACHLIST is the buffer cache | ||
| 898 | which must be updated. | ||
| 899 | CACHELIST must be searched to find where NEWTAGS are to be inserted. | ||
| 900 | The positions of NEWTAGS must be synchronized with those in | ||
| 901 | CACHELIST for this to work. Some routines pre-position CACHLIST at a | ||
| 902 | convenient 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. | ||
| 929 | Do this by recycling OLDTAG's first CONS cell. This effectivly | ||
| 930 | causes the new tag to completely replace the old one. | ||
| 931 | Make sure that all information in the overlay is transferred. | ||
| 932 | It is presumed that OLDTAG and NEWTAG are both cooked. | ||
| 933 | When this routine returns, OLDTAG is raw, and the data will be | ||
| 934 | lost 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. | ||
| 71 | INGNORE any arguments. Always parse the whole buffer. | ||
| 72 | Each tag returned is of the form: | ||
| 73 | (\"NAME\" section (:members CHILDREN)) | ||
| 74 | or | ||
| 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. | ||
| 120 | METATAGLIST is a list of tags in the intermediate tag format used by the | ||
| 121 | html 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. | ||
| 133 | NAME is the name of this section. | ||
| 134 | MEMBERS is a list of semantic tags representing the elements that make | ||
| 135 | up this section. | ||
| 136 | LEVEL is the levelling level. | ||
| 137 | START 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. | ||
| 147 | Assume the cursor is in the tag representing the section we | ||
| 148 | need 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. | ||
| 172 | Return the rearranged new list, with all remaining tags from | ||
| 173 | SECTIONLIST starting at ELT 2. Sections not are not dealt with as soon as a | ||
| 174 | tag 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. | ||
| 55 | Use 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. | ||
| 61 | This time should be short enough to ensure that idle-scheduler will be | ||
| 62 | run 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. | ||
| 74 | This time should be long enough that once any big work is started, it is | ||
| 75 | unlikely 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'. | ||
| 125 | The idle scheduler with automatically reparse buffers in idle time, | ||
| 126 | and then schedule other jobs setup with `semantic-idle-scheduler-add'. | ||
| 127 | If ARG is positive, enable, if it is negative, disable. | ||
| 128 | If 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. | ||
| 142 | Use 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. | ||
| 147 | If this value is less than or equal to 0, idle-scheduler is enabled in | ||
| 148 | all 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. | ||
| 154 | idle-scheduler is disabled when debugging or if the buffer size | ||
| 155 | exceeds 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'. | ||
| 164 | The minor mode can be turned on only if semantic feature is available | ||
| 165 | and the current buffer was set up for parsing. When minor mode is | ||
| 166 | enabled parse the current buffer if needed. Return non-nil if the | ||
| 167 | minor 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. | ||
| 181 | When this mode is off, a buffer is only rescanned for tokens when | ||
| 182 | some command requests the list of available tokens. When idle-scheduler | ||
| 183 | is enabled, Emacs periodically checks to see if the buffer is out of | ||
| 184 | date, and reparses while the user is idle (not typing.) | ||
| 185 | |||
| 186 | With prefix argument ARG, turn on if positive, otherwise off. The | ||
| 187 | minor mode can be turned on only if semantic feature is available and | ||
| 188 | the current buffer was set up for parsing. Return non-nil if the | ||
| 189 | minor 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. | ||
| 223 | These functions will be called in the current buffer after that | ||
| 224 | buffer has had its tags made up to date. These functions | ||
| 225 | will not be called if there are errors parsing the | ||
| 226 | current 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. | ||
| 243 | And 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'. | ||
| 319 | This function will reparse the current buffer, and if successful, | ||
| 320 | call 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. | ||
| 333 | Disable 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. | ||
| 340 | Uses `semantic-safe' and returns the output. | ||
| 341 | Returns 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. | ||
| 372 | Visits semantic controlled buffers, and makes sure all needed | ||
| 373 | include files have been parsed, and that the typecache is up to date. | ||
| 374 | Uses `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'. | ||
| 445 | This routine handles difficult tasks that require a lot of parsing, such as | ||
| 446 | parsing all the header files used by our active sources, or building up complex | ||
| 447 | datasets." | ||
| 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. | ||
| 499 | If any hook throws an error, this variable is reset to nil. | ||
| 500 | This 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. | ||
| 504 | If any hook throws an error, this variable is reset to nil. | ||
| 505 | This hook is not protected from lexical errors.") | ||
| 506 | |||
| 507 | (defun semantic-idle-scheduler-refresh-tags () | ||
| 508 | "Refreshes the current buffer's tags. | ||
| 509 | This is called by `semantic-idle-scheduler-function' to update the | ||
| 510 | tags in the current buffer. | ||
| 511 | |||
| 512 | Return non-nil if the refresh was successful. | ||
| 513 | Return nil if there is some sort of syntax error preventing a full | ||
| 514 | reparse. | ||
| 515 | |||
| 516 | Does 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. | ||
| 594 | DOC will be a documentation string describing FORMS. | ||
| 595 | FORMS will be called during idle time after the current buffer's | ||
| 596 | semantic tag information has been updated. | ||
| 597 | This 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) "'. | ||
| 609 | If ARG is positive, enable, if it is negative, disable. | ||
| 610 | If 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. | ||
| 639 | Use 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) "'. | ||
| 644 | The minor mode can be turned on only if semantic feature is available | ||
| 645 | and the idle scheduler is active. | ||
| 646 | Return 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 " | ||
| 665 | This is a minor mode which performs actions during idle time. | ||
| 666 | With prefix argument ARG, turn on if positive, otherwise off. The | ||
| 667 | minor mode can be turned on only if semantic feature is available and | ||
| 668 | the current buffer was set up for parsing. Return non-nil if the | ||
| 669 | minor 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. | ||
| 708 | Some 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. | ||
| 714 | Return the tag found or nil if not found. | ||
| 715 | If 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. | ||
| 722 | Gets a symbol with `semantic-ctxt-current-thing' and then | ||
| 723 | trys 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. | ||
| 731 | Returns 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. | ||
| 739 | Use 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. | ||
| 748 | This functin will disable loading of previously unloaded files | ||
| 749 | by 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. | ||
| 774 | Those are generally faces used to highlight comments. | ||
| 775 | |||
| 776 | It might be useful to override this variable to add comment faces | ||
| 777 | specific 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. | ||
| 807 | Call `semantic-idle-summary-current-symbol-info' for getting the | ||
| 808 | current 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. | ||
| 842 | TAG was found as the thing under point. If it happens to be | ||
| 843 | visible, 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. | ||
| 894 | Call `semantic-analyze-current-context' to find the reference tag. | ||
| 895 | Call `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. | ||
| 327 | Return 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. | ||
| 334 | See 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. | ||
| 339 | See 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. | ||
| 344 | Argument SYNTAX indicates the type of syntax that is unterminated. | ||
| 345 | The job of this function is to move (point) to a new logical location | ||
| 346 | so 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'." | |||
| 1012 | See also the function `semantic-lex-token'." | 1048 | See 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. | ||
| 1017 | Return 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. | ||
| 1024 | See 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. | ||
| 1029 | See 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. |
| 1034 | See also the function `semantic-lex-token'." | 1053 | See 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. | ||
| 1090 | Argument SYNTAX indicates the type of syntax that is unterminated. | ||
| 1091 | The job of this function is to move (point) to a new logical location | ||
| 1092 | so 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\\)?\\|\ | ||
| 45 | centerchap\\|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. | ||
| 58 | The field position is the field number (based at 1) where the | ||
| 59 | name of this section is.") | ||
| 60 | |||
| 61 | ;;; Code: | ||
| 62 | (defun semantic-texi-parse-region (&rest ignore) | ||
| 63 | "Parse the current texinfo buffer for semantic tags. | ||
| 64 | IGNORE any arguments, always parse the whole buffer. | ||
| 65 | Each tag returned is of the form: | ||
| 66 | (\"NAME\" section (:members CHILDREN)) | ||
| 67 | or | ||
| 68 | (\"NAME\" def) | ||
| 69 | |||
| 70 | It is an override of 'parse-region and must be installed by the | ||
| 71 | function `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. | ||
| 111 | NAME is the name of this section. | ||
| 112 | MEMBERS is a list of semantic tags representing the elements that make | ||
| 113 | up this section. | ||
| 114 | START 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. | ||
| 120 | NAME is the name of this definition. | ||
| 121 | START 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. | ||
| 127 | METATAGLIST is a list of tags in the intermediate tag format used by the | ||
| 128 | texinfo 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. | ||
| 140 | Return the rearranged new list, with all remaining tags from | ||
| 141 | SECTIONLIST starting at ELT 2. Sections not are not dealt with as soon as a | ||
| 142 | tag 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. | ||
| 225 | The 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. | ||
| 253 | uses `texinfo-environment-regexp', but makes sure that it | ||
| 254 | can 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. | ||
| 306 | For texinfo, there two possibilities returned. | ||
| 307 | 1) 'function - for a call to a texinfo function | ||
| 308 | 2) 'word - indicates an english word. | ||
| 309 | It 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. | ||
| 342 | The text bounds is the text belonging to this node excluding | ||
| 343 | the 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. | ||
| 356 | Optional 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. | ||
| 421 | Since texinfo is not a programming language the default version is not | ||
| 422 | useful. Insted, look at the current symbol. If it is a command | ||
| 423 | do primitive texinfo built ins. If not, use ispell to lookup words | ||
| 424 | that 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. | ||
| 507 | NAME is a string representing some functional symbol. | ||
| 508 | TYPE is a string, such as \"variable\" or \"Command\" used to find | ||
| 509 | the correct definition in case NAME qualifies as several things. | ||
| 510 | When this function exists, POINT is at the definition. | ||
| 511 | If the doc was not found, an error is thrown. | ||
| 512 | Note: 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. | ||
| 527 | The current buffer must be a texinfo file containing TAG. | ||
| 528 | If 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. | ||
| 594 | The current buffer must be a non-texinfo source file containing TAG. | ||
| 595 | If TAG is nil, determine the tag based on the current position. | ||
| 596 | The 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. | ||
| 633 | If the current buffer is a texinfo file, then find the source doc, and | ||
| 634 | update it. If the current buffer is a source file, then get the | ||
| 635 | documentation for this item, find the existing doc in the associated | ||
| 636 | manual, 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. | ||
| 645 | If 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 | ||