Mercurial > emacs
changeset 104419:b1ac14799f78
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.
author | Chong Yidong <cyd@stupidchicken.com> |
---|---|
date | Sat, 29 Aug 2009 19:00:35 +0000 |
parents | 12884dc43872 |
children | 2e15afd37998 |
files | lisp/cedet/semantic/analyze.el lisp/cedet/semantic/complete.el lisp/cedet/semantic/edit.el lisp/cedet/semantic/html.el lisp/cedet/semantic/idle.el lisp/cedet/semantic/lex.el lisp/cedet/semantic/texi.el |
diffstat | 7 files changed, 5794 insertions(+), 30 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/analyze.el Sat Aug 29 19:00:35 2009 +0000 @@ -0,0 +1,769 @@ +;;; analyze.el --- Analyze semantic tags against local context + +;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Semantic, as a tool, provides a nice list of searchable tags. +;; That information can provide some very accurate answers if the current +;; context of a position is known. +;; +;; Semantic-ctxt provides ways of analyzing, and manipulating the +;; semantic context of a language in code. +;; +;; This library provides routines for finding intelligent answers to +;; tough problems, such as if an argument to a function has the correct +;; return type, or all possible tags that fit in a given local context. +;; + +;;; Vocabulary: +;; +;; Here are some words used to describe different things in the analyzer: +;; +;; tag - A single entity +;; prefix - The beginning of a symbol, usually used to look up something +;; incomplete. +;; type - The name of a datatype in the langauge. +;; metatype - If a type is named in a declaration like: +;; struct moose somevariable; +;; that name "moose" can be turned into a concrete type. +;; tag sequence - In C code, a list of dereferences, such as: +;; this.that.theother(); +;; parent - For a datatype in an OO language, another datatype +;; inherited from. This excludes interfaces. +;; scope - A list of tags that can be dereferenced that cannot +;; be found from the global namespace. +;; scopetypes - A list of tags which are datatype that contain +;; the scope. The scopetypes need to have the scope extracted +;; in a way that honors the type of inheritance. +;; nest/nested - When one tag is contained entirely in another. +;; +;; context - A semantic datatype representing a point in a buffer. +;; +;; constriant - If a context specifies a specific datatype is needed, +;; that is a constraint. +;; constants - Some datatypes define elements of themselves as a +;; constant. These need to be returned as there would be no +;; other possible completions. +;; +(require 'eieio) +;; (require 'inversion) +;; (eval-and-compile +;; (inversion-require 'eieio "1.0")) +(require 'semantic) +(require 'semantic/format) +(require 'semantic/ctxt) +(require 'semantic/sort) +(eval-when-compile (require 'semantic/db) + (require 'semantic/db-find)) + +(require 'semantic/scope) +(require 'semantic/analyze/fcn) + +;;; Code: +(defvar semantic-analyze-error-stack nil + "Collection of any errors thrown during analysis.") + +(defun semantic-analyze-push-error (err) + "Push the error in ERR-DATA onto the error stack. +Argument ERR" + (push err semantic-analyze-error-stack)) + +;;; Analysis Classes +;; +;; These classes represent what a context is. Different types +;; of contexts provide differing amounts of information to help +;; provide completions. +;; +(defclass semantic-analyze-context () + ((bounds :initarg :bounds + :type list + :documentation "The bounds of this context. +Usually bound to the dimension of a single symbol or command.") + (prefix :initarg :prefix + :type list + :documentation "List of tags defining local text. +This can be nil, or a list where the last element can be a string +representing text that may be incomplete. Preceeding elements +must be semantic tags representing variables or functions +called in a dereference sequence.") + (prefixclass :initarg :prefixclass + :type list + :documentation "Tag classes expected at this context. +These are clases for tags, such as 'function, or 'variable.") + (prefixtypes :initarg :prefixtypes + :type list + :documentation "List of tags defining types for :prefix. +This list is one shorter than :prefix. Each element is a semantic +tag representing a type matching the semantic tag in the same +position in PREFIX.") + (scope :initarg :scope + :type (or null semantic-scope-cache) + :documentation "List of tags available in scopetype. +See `semantic-analyze-scoped-tags' for details.") + (buffer :initarg :buffer + :type buffer + :documentation "The buffer this context is derived from.") + (errors :initarg :errors + :documentation "Any errors thrown an caught during analysis.") + ) + "Base analysis data for a any context.") + +(defclass semantic-analyze-context-assignment (semantic-analyze-context) + ((assignee :initarg :assignee + :type list + :documentation "A sequence of tags for an assignee. +This is a variable into which some value is being placed. The last +item in the list is the variable accepting the value. Earlier +tags represent the variables being derefernece to get to the +assignee.")) + "Analysis class for a value in an assignment.") + +(defclass semantic-analyze-context-functionarg (semantic-analyze-context) + ((function :initarg :function + :type list + :documentation "A sequence of tags for a function. +This is a function being called. The cursor will be in the position +of an argument. +The last tag in :function is the function being called. Earlier +tags represent the variables being dereferenced to get to the +function.") + (index :initarg :index + :type integer + :documentation "The index of the argument for this context. +If a function takes 4 arguments, this value should be bound to +the values 1 through 4.") + (argument :initarg :argument + :type list + :documentation "A sequence of tags for the :index argument. +The argument can accept a value of some type, and this contains the +tag for that definition. It should be a tag, but might +be just a string in some circumstances.") + ) + "Analysis class for a value as a function argument.") + +(defclass semantic-analyze-context-return (semantic-analyze-context) + () ; No extra data. + "Analysis class for return data. +Return data methods identify the requred type by the return value +of the parent function.") + +;;; METHODS +;; +;; Simple methods against the context classes. +;; +(defmethod semantic-analyze-type-constraint + ((context semantic-analyze-context) &optional desired-type) + "Return a type constraint for completing :prefix in CONTEXT. +Optional argument DESIRED-TYPE may be a non-type tag to analyze." + (when (semantic-tag-p desired-type) + ;; Convert the desired type if needed. + (if (not (eq (semantic-tag-class desired-type) 'type)) + (setq desired-type (semantic-tag-type desired-type))) + ;; Protect against plain strings + (cond ((stringp desired-type) + (setq desired-type (list desired-type 'type))) + ((and (stringp (car desired-type)) + (not (semantic-tag-p desired-type))) + (setq desired-type (list (car desired-type) 'type))) + ((semantic-tag-p desired-type) + ;; We have a tag of some sort. Yay! + nil) + (t (setq desired-type nil)) + ) + desired-type)) + +(defmethod semantic-analyze-type-constraint + ((context semantic-analyze-context-functionarg)) + "Return a type constraint for completing :prefix in CONTEXT." + (call-next-method context (car (oref context argument)))) + +(defmethod semantic-analyze-type-constraint + ((context semantic-analyze-context-assignment)) + "Return a type constraint for completing :prefix in CONTEXT." + (call-next-method context (car (reverse (oref context assignee))))) + +(defmethod semantic-analyze-interesting-tag + ((context semantic-analyze-context)) + "Return a tag from CONTEXT that would be most interesting to a user." + (let ((prefix (reverse (oref context :prefix)))) + ;; Go back through the prefix until we find a tag we can return. + (while (and prefix (not (semantic-tag-p (car prefix)))) + (setq prefix (cdr prefix))) + ;; Return the found tag, or nil. + (car prefix))) + +(defmethod semantic-analyze-interesting-tag + ((context semantic-analyze-context-functionarg)) + "Try the base, and if that fails, return what we are assigning into." + (or (call-next-method) (car-safe (oref context :function)))) + +(defmethod semantic-analyze-interesting-tag + ((context semantic-analyze-context-assignment)) + "Try the base, and if that fails, return what we are assigning into." + (or (call-next-method) (car-safe (oref context :assignee)))) + +;;; ANALYSIS +;; +;; Start out with routines that will calculate useful parts of +;; the general analyzer function. These could be used directly +;; by an application that doesn't need to calculate the full +;; context. + +(define-overloadable-function semantic-analyze-find-tag-sequence (sequence &optional + scope typereturn throwsym) + "Attempt to find all tags in SEQUENCE. +Optional argument LOCALVAR is the list of local variables to use when +finding the details on the first element of SEQUENCE in case +it is not found in the global set of tables. +Optional argument SCOPE are additional terminals to search which are currently +scoped. These are not local variables, but symbols available in a structure +which doesn't need to be dereferneced. +Optional argument TYPERETURN is a symbol in which the types of all found +will be stored. If nil, that data is thrown away. +Optional argument THROWSYM specifies a symbol the throw on non-recoverable error.") + +(defun semantic-analyze-find-tag-sequence-default (sequence &optional + scope typereturn + throwsym) + "Attempt to find all tags in SEQUENCE. +SCOPE are extra tags which are in scope. +TYPERETURN is a symbol in which to place a list of tag classes that +are found in SEQUENCE. +Optional argument THROWSYM specifies a symbol the throw on non-recoverable error." + (let ((s sequence) ; copy of the sequence + (tmp nil) ; tmp find variable + (tag nil) ; tag return list + (tagtype nil) ; tag types return list + (fname nil) + (miniscope (clone scope)) + ) + ;; First order check. Is this wholely contained in the typecache? + (setq tmp (semanticdb-typecache-find sequence)) + + (if tmp + (progn + ;; We are effectively done... + (setq s nil) + (setq tag (list tmp))) + + ;; For the first entry, it better be a variable, but it might + ;; be in the local context too. + ;; NOTE: Don't forget c++ namespace foo::bar. + (setq tmp (or + ;; Is this tag within our scope. Scopes can sometimes + ;; shadow other things, so it goes first. + (and scope (semantic-scope-find (car s) nil scope)) + ;; Find the tag out there... somewhere, but not in scope + (semantic-analyze-find-tag (car s)) + )) + + (if (and (listp tmp) (semantic-tag-p (car tmp))) + (setq tmp (semantic-analyze-select-best-tag tmp))) + (if (not (semantic-tag-p tmp)) + (if throwsym + (throw throwsym "Cannot find definition") + (error "Cannot find definition for \"%s\"" (car s)))) + (setq s (cdr s)) + (setq tag (cons tmp tag)) ; tag is nil here... + (setq fname (semantic-tag-file-name tmp)) + ) + + ;; For the middle entries + (while s + ;; Using the tag found in TMP, lets find the tag + ;; representing the full typeographic information of its + ;; type, and use that to determine the search context for + ;; (car s) + (let* ((tmptype + ;; In some cases the found TMP is a type, + ;; and we can use it directly. + (cond ((semantic-tag-of-class-p tmp 'type) + ;; update the miniscope when we need to analyze types directly. + (let ((rawscope + (apply 'append + (mapcar 'semantic-tag-type-members + tagtype)))) + (oset miniscope fullscope rawscope)) + ;; Now analayze the type to remove metatypes. + (or (semantic-analyze-type tmp miniscope) + tmp)) + (t + (semantic-analyze-tag-type tmp scope)))) + (typefile + (when tmptype + (semantic-tag-file-name tmptype))) + (slots nil)) + + ;; Get the children + (setq slots (semantic-analyze-scoped-type-parts tmptype scope)) + + ;; find (car s) in the list o slots + (setq tmp (semantic-find-tags-by-name (car s) slots)) + + ;; If we have lots + (if (and (listp tmp) (semantic-tag-p (car tmp))) + (setq tmp (semantic-analyze-select-best-tag tmp))) + + ;; Make sure we have a tag. + (if (not (semantic-tag-p tmp)) + (if (cdr s) + ;; In the middle, we need to keep seeking our types out. + (error "Cannot find definition for \"%s\"" (car s)) + ;; Else, it's ok to end with a non-tag + (setq tmp (car s)))) + + (setq fname (or typefile fname)) + (when (and fname (semantic-tag-p tmp) + (not (semantic-tag-in-buffer-p tmp))) + (semantic--tag-put-property tmp :filename fname)) + (setq tag (cons tmp tag)) + (setq tagtype (cons tmptype tagtype)) + ) + (setq s (cdr s))) + + (if typereturn (set typereturn (nreverse tagtype))) + ;; Return the mess + (nreverse tag))) + +(defun semantic-analyze-find-tag (name &optional tagclass scope) + "Return the first tag found with NAME or nil if not found. +Optional argument TAGCLASS specifies the class of tag to return, such +as 'function or 'variable. +Optional argument SCOPE specifies a scope object which has +additional tags which are in SCOPE and do not need prefixing to +find. + +This is a wrapper on top of semanticdb, semanticdb-typecache, +semantic-scope, and semantic search functions. Almost all +searches use the same arguments." + (let ((namelst (if (consp name) name ;; test if pre-split. + (semantic-analyze-split-name name)))) + (cond + ;; If the splitter gives us a list, use the sequence finder + ;; to get the list. Since this routine is expected to return + ;; only one tag, return the LAST tag found from the sequence + ;; which is supposedly the nested reference. + ;; + ;; Of note, the SEQUENCE function below calls this function + ;; (recursively now) so the names that we get from the above + ;; fcn better not, in turn, be splittable. + ((listp namelst) + ;; If we had a split, then this is likely a c++ style namespace::name sequence, + ;; so take a short-cut through the typecache. + (or (semanticdb-typecache-find namelst) + ;; Ok, not there, try the usual... + (let ((seq (semantic-analyze-find-tag-sequence + namelst scope nil))) + (semantic-analyze-select-best-tag seq tagclass) + ))) + ;; If NAME is solo, then do our searches for it here. + ((stringp namelst) + (let ((retlist (and scope (semantic-scope-find name tagclass scope)))) + (if retlist + (semantic-analyze-select-best-tag + retlist tagclass) + (if (eq tagclass 'type) + (semanticdb-typecache-find name) + ;; Search in the typecache. First entries in a sequence are + ;; often there. + (setq retlist (semanticdb-typecache-find name)) + (if retlist + retlist + (semantic-analyze-select-best-tag + (semanticdb-strip-find-results + (semanticdb-find-tags-by-name name) + 'name) + tagclass) + ))))) + ))) + +;;; SHORT ANALYSIS +;; +;; Create a mini-analysis of just the symbol under point. +;; +(define-overloadable-function semantic-analyze-current-symbol + (analyzehookfcn &optional position) + "Call ANALYZEHOOKFCN after analyzing the symbol under POSITION. +The ANALYZEHOOKFCN is called with the current symbol bounds, and the +analyzed prefix. It should take the arguments (START END PREFIX). +The ANALYZEHOOKFCN is only called if some sort of prefix with bounds was +found under POSITION. + +The results of ANALYZEHOOKFCN is returned, or nil if there was nothing to +call it with. + +For regular analysis, you should call `semantic-analyze-current-context' +to calculate the context information. The purpose for this function is +to provide a large number of non-cached analysis for filtering symbols." + ;; Only do this in a Semantic enabled buffer. + (when (not (semantic-active-p)) + (error "Cannot analyze buffers not supported by Semantic.")) + ;; Always refresh out tags in a safe way before doing the + ;; context. + (semantic-refresh-tags-safe) + ;; Do the rest of the analysis. + (save-match-data + (save-excursion + (:override))) + ) + +(defun semantic-analyze-current-symbol-default (analyzehookfcn position) + "Call ANALYZEHOOKFCN on the analyzed symbol at POSITION." + (let* ((semantic-analyze-error-stack nil) + (LLstart (current-time)) + (prefixandbounds (semantic-ctxt-current-symbol-and-bounds (or position (point)))) + (prefix (car prefixandbounds)) + (bounds (nth 2 prefixandbounds)) + (scope (semantic-calculate-scope position)) + (end nil) + ) + ;; Only do work if we have bounds (meaning a prefix to complete) + (when bounds + + (if debug-on-error + (catch 'unfindable + ;; If debug on error is on, allow debugging in this fcn. + (setq prefix (semantic-analyze-find-tag-sequence + prefix scope 'prefixtypes 'unfindable))) + ;; Debug on error is off. Capture errors and move on + (condition-case err + ;; NOTE: This line is duplicated in + ;; semantic-analyzer-debug-global-symbol + ;; You will need to update both places. + (setq prefix (semantic-analyze-find-tag-sequence + prefix scope 'prefixtypes)) + (error (semantic-analyze-push-error err)))) + + (setq end (current-time)) + ;;(message "Analysis took %.2f sec" (semantic-elapsed-time LLstart end)) + + ) + (when prefix + (prog1 + (funcall analyzehookfcn (car bounds) (cdr bounds) prefix) + ;;(setq end (current-time)) + ;;(message "hookfcn took %.5f sec" (semantic-elapsed-time LLstart end)) + ) + + ))) + +;;; MAIN ANALYSIS +;; +;; Create a full-up context analysis. +;; +(define-overloadable-function semantic-analyze-current-context (&optional position) + "Analyze the current context at optional POSITION. +If called interactively, display interesting information about POSITION +in a separate buffer. +Returns an object based on symbol `semantic-analyze-context'. + +This function can be overriden with the symbol `analyze-context'. +When overriding this function, your override will be called while +cursor is at POSITION. In addition, your function will not be called +if a cached copy of the return object is found." + (interactive "d") + ;; Only do this in a Semantic enabled buffer. + (when (not (semantic-active-p)) + (error "Cannot analyze buffers not supported by Semantic.")) + ;; Always refresh out tags in a safe way before doing the + ;; context. + (semantic-refresh-tags-safe) + ;; Do the rest of the analysis. + (if (not position) (setq position (point))) + (save-excursion + (goto-char position) + (let* ((answer (semantic-get-cache-data 'current-context))) + (with-syntax-table semantic-lex-syntax-table + (when (not answer) + (setq answer (:override)) + (when (and answer (oref answer bounds)) + (with-slots (bounds) answer + (semantic-cache-data-to-buffer (current-buffer) + (car bounds) + (cdr bounds) + answer + 'current-context + 'exit-cache-zone))) + ;; Check for interactivity + (when (interactive-p) + (if answer + (semantic-analyze-pop-to-context answer) + (message "No Context.")) + )) + + answer)))) + +(defun semantic-analyze-current-context-default (position) + "Analyze the current context at POSITION. +Returns an object based on symbol `semantic-analyze-context'." + (let* ((semantic-analyze-error-stack nil) + (context-return nil) + (prefixandbounds (semantic-ctxt-current-symbol-and-bounds (or position (point)))) + (prefix (car prefixandbounds)) + (bounds (nth 2 prefixandbounds)) + ;; @todo - vv too early to really know this answer! vv + (prefixclass (semantic-ctxt-current-class-list)) + (prefixtypes nil) + (scope (semantic-calculate-scope position)) + (function nil) + (fntag nil) + arg fntagend argtag + assign asstag + ) + + ;; Pattern for Analysis: + ;; + ;; Step 1: Calculate DataTypes in Scope: + ;; + ;; a) Calculate the scope (above) + ;; + ;; Step 2: Parse context + ;; + ;; a) Identify function being called, or variable assignment, + ;; and find source tags for those references + ;; b) Identify the prefix (text cursor is on) and find the source + ;; tags for those references. + ;; + ;; Step 3: Assemble an object + ;; + + ;; Step 2 a: + + (setq function (semantic-ctxt-current-function)) + + (when function + ;; Calculate the argument for the function if there is one. + (setq arg (semantic-ctxt-current-argument)) + + ;; Find a tag related to the function name. + (condition-case err + (setq fntag + (semantic-analyze-find-tag-sequence function scope)) + (error (semantic-analyze-push-error err))) + + ;; fntag can have the last entry as just a string, meaning we + ;; could not find the core datatype. In this case, the searches + ;; below will not work. + (when (stringp (car (last fntag))) + ;; Take a wild guess! + (setcar (last fntag) (semantic-tag (car (last fntag)) 'function)) + ) + + (when fntag + (let ((fcn (semantic-find-tags-by-class 'function fntag))) + (when (not fcn) + (let ((ty (semantic-find-tags-by-class 'type fntag))) + (when ty + ;; We might have a constructor with the same name as + ;; the found datatype. + (setq fcn (semantic-find-tags-by-name + (semantic-tag-name (car ty)) + (semantic-tag-type-members (car ty)))) + (if fcn + (let ((lp fcn)) + (while lp + (when (semantic-tag-get-attribute (car lp) + :constructor) + (setq fcn (cons (car lp) fcn))) + (setq lp (cdr lp)))) + ;; Give up, go old school + (setq fcn fntag)) + ))) + (setq fntagend (car (reverse fcn)) + argtag + (when (semantic-tag-p fntagend) + (nth (1- arg) (semantic-tag-function-arguments fntagend))) + fntag fcn)))) + + ;; Step 2 b: + + ;; Only do work if we have bounds (meaning a prefix to complete) + (when bounds + + (if debug-on-error + (catch 'unfindable + ;; If debug on error is on, allow debugging in this fcn. + (setq prefix (semantic-analyze-find-tag-sequence + prefix scope 'prefixtypes 'unfindable))) + ;; Debug on error is off. Capture errors and move on + (condition-case err + ;; NOTE: This line is duplicated in + ;; semantic-analyzer-debug-global-symbol + ;; You will need to update both places. + (setq prefix (semantic-analyze-find-tag-sequence + prefix scope 'prefixtypes)) + (error (semantic-analyze-push-error err)))) + ) + + ;; Step 3: + + (cond + (fntag + ;; If we found a tag for our function, we can go into + ;; functional context analysis mode, meaning we have a type + ;; for the argument. + (setq context-return + (semantic-analyze-context-functionarg + "functionargument" + :buffer (current-buffer) + :function fntag + :index arg + :argument (list argtag) + :scope scope + :prefix prefix + :prefixclass prefixclass + :bounds bounds + :prefixtypes prefixtypes + :errors semantic-analyze-error-stack))) + + ;; No function, try assignment + ((and (setq assign (semantic-ctxt-current-assignment)) + ;; We have some sort of an assignment + (condition-case err + (setq asstag (semantic-analyze-find-tag-sequence + assign scope)) + (error (semantic-analyze-push-error err) + nil))) + + (setq context-return + (semantic-analyze-context-assignment + "assignment" + :buffer (current-buffer) + :assignee asstag + :scope scope + :bounds bounds + :prefix prefix + :prefixclass prefixclass + :prefixtypes prefixtypes + :errors semantic-analyze-error-stack))) + + ;; TODO: Identify return value condition. + ;;((setq return .... what to do?) + ;; ...) + + (bounds + ;; Nothing in particular + (setq context-return + (semantic-analyze-context + "context" + :buffer (current-buffer) + :scope scope + :bounds bounds + :prefix prefix + :prefixclass prefixclass + :prefixtypes prefixtypes + :errors semantic-analyze-error-stack))) + + (t (setq context-return nil)) + ) + + ;; Return our context. + context-return)) + + +;;; DEBUG OUTPUT +;; +;; Friendly output of a context analysis. +;; +(defmethod semantic-analyze-pulse ((context semantic-analyze-context)) + "Pulse the region that CONTEXT affects." + (save-excursion + (set-buffer (oref context :buffer)) + (let ((bounds (oref context :bounds))) + (when bounds + (pulse-momentary-highlight-region (car bounds) (cdr bounds)))))) + +(defcustom semantic-analyze-summary-function 'semantic-format-tag-prototype + "*Function to use when creating items in Imenu. +Some useful functions are found in `semantic-format-tag-functions'." + :group 'semantic + :type semantic-format-tag-custom-list) + +(defun semantic-analyze-princ-sequence (sequence &optional prefix buff) + "Send the tag SEQUENCE to standard out. +Use PREFIX as a label. +Use BUFF as a source of override methods." + (while sequence + (princ prefix) + (cond + ((semantic-tag-p (car sequence)) + (princ (funcall semantic-analyze-summary-function + (car sequence)))) + ((stringp (car sequence)) + (princ "\"") + (princ (semantic--format-colorize-text (car sequence) 'variable)) + (princ "\"")) + (t + (princ (format "'%S" (car sequence))))) + (princ "\n") + (setq sequence (cdr sequence)) + (setq prefix (make-string (length prefix) ? )) + )) + +(defmethod semantic-analyze-show ((context semantic-analyze-context)) + "Insert CONTEXT into the current buffer in a nice way." + (semantic-analyze-princ-sequence (oref context prefix) "Prefix: " ) + (semantic-analyze-princ-sequence (oref context prefixclass) "Prefix Classes: ") + (semantic-analyze-princ-sequence (oref context prefixtypes) "Prefix Types: ") + (semantic-analyze-princ-sequence (oref context errors) "Encountered Errors: ") + (princ "--------\n") + ;(semantic-analyze-princ-sequence (oref context scopetypes) "Scope Types: ") + ;(semantic-analyze-princ-sequence (oref context scope) "Scope: ") + ;(semantic-analyze-princ-sequence (oref context localvariables) "LocalVars: ") + (when (oref context scope) + (semantic-analyze-show (oref context scope))) + ) + +(defmethod semantic-analyze-show ((context semantic-analyze-context-assignment)) + "Insert CONTEXT into the current buffer in a nice way." + (semantic-analyze-princ-sequence (oref context assignee) "Assignee: ") + (call-next-method)) + +(defmethod semantic-analyze-show ((context semantic-analyze-context-functionarg)) + "Insert CONTEXT into the current buffer in a nice way." + (semantic-analyze-princ-sequence (oref context function) "Function: ") + (princ "Argument Index: ") + (princ (oref context index)) + (princ "\n") + (semantic-analyze-princ-sequence (oref context argument) "Argument: ") + (call-next-method)) + +(defun semantic-analyze-pop-to-context (context) + "Display CONTEXT in a temporary buffer. +CONTEXT's content is described in `semantic-analyze-current-context'." + (semantic-analyze-pulse context) + (with-output-to-temp-buffer "*Semantic Context Analysis*" + (princ "Context Type: ") + (princ (object-name context)) + (princ "\n") + (princ "Bounds: ") + (princ (oref context bounds)) + (princ "\n") + (semantic-analyze-show context) + ) + (shrink-window-if-larger-than-buffer + (get-buffer-window "*Semantic Context Analysis*")) + ) + +(provide 'semantic/analyze) + +;;; semantic-analyze.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/complete.el Sat Aug 29 19:00:35 2009 +0000 @@ -0,0 +1,2128 @@ +;;; complete.el --- Routines for performing tag completion + +;;; Copyright (C) 2003, 2004, 2005, 2007, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Completion of tags by name using tables of semantic generated tags. +;; +;; While it would be a simple matter of flattening all tag known +;; tables to perform completion across them using `all-completions', +;; or `try-completion', that process would be slow. In particular, +;; when a system database is included in the mix, the potential for a +;; ludicrous number of options becomes apparent. +;; +;; As such, dynamically searching across tables using a prefix, +;; regular expression, or other feature is needed to help find symbols +;; quickly without resorting to "show me every possible option now". +;; +;; In addition, some symbol names will appear in multiple locations. +;; If it is important to distiguish, then a way to provide a choice +;; over these locations is important as well. +;; +;; Beyond brute force offers for completion of plain strings, +;; using the smarts of semantic-analyze to provide reduced lists of +;; symbols, or fancy tabbing to zoom into files to show multiple hits +;; of the same name can be provided. +;; +;;; How it works: +;; +;; There are several parts of any completion engine. They are: +;; +;; A. Collection of possible hits +;; B. Typing or selecting an option +;; C. Displaying possible unique completions +;; D. Using the result +;; +;; Here, we will treat each section separately (excluding D) +;; They can then be strung together in user-visible commands to +;; fullfill specific needs. +;; +;; COLLECTORS: +;; +;; A collector is an object which represents the means by which tags +;; to complete on are collected. It's first job is to find all the +;; tags which are to be completed against. It can also rename +;; some tags if needed so long as `semantic-tag-clone' is used. +;; +;; Some collectors will gather all tags to complete against first +;; (for in buffer queries, or other small list situations). It may +;; choose to do a broad search on each completion request. Built in +;; functionality automatically focuses the cache in as the user types. +;; +;; A collector choosing to create and rename tags could choose a +;; plain name format, a postfix name such as method:class, or a +;; prefix name such as class.method. +;; +;; DISPLAYORS +;; +;; A displayor is in charge if showing the user interesting things +;; about available completions, and can optionally provide a focus. +;; The simplest display just lists all available names in a separate +;; window. It may even choose to show short names when there are +;; many to choose from, or long names when there are fewer. +;; +;; A complex displayor could opt to help the user 'focus' on some +;; range. For example, if 4 tags all have the same name, subsequent +;; calls to the displayor may opt to show each tag one at a time in +;; the buffer. When the user likes one, selection would cause the +;; 'focus' item to be selected. +;; +;; CACHE FORMAT +;; +;; The format of the tag lists used to perform the completions are in +;; semanticdb "find" format, like this: +;; +;; ( ( DBTABLE1 TAG1 TAG2 ...) +;; ( DBTABLE2 TAG1 TAG2 ...) +;; ... ) +;; +;; INLINE vs MINIBUFFER +;; +;; Two major ways completion is used in Emacs is either through a +;; minibuffer query, or via completion in a normal editing buffer, +;; encompassing some small range of characters. +;; +;; Structure for both types of completion are provided here. +;; `semantic-complete-read-tag-engine' will use the minibuffer. +;; `semantic-complete-inline-tag-engine' will complete text in +;; a buffer. + +(require 'eieio) +(require 'semantic/tag) +(require 'semantic/find) +(require 'semantic/analyze) +(require 'semantic/format) +(require 'semantic/ctxt) +;; Keep semanticdb optional. +(eval-when-compile + (require 'semantic/db) + (require 'semantic/db-find)) + +(eval-when-compile + (condition-case nil + ;; Tooltip not available in older emacsen. + (require 'tooltip) + (error nil)) + ) + +;;; Code: + +;;; Compatibility +;; +(if (fboundp 'minibuffer-contents) + (eval-and-compile (defalias 'semantic-minibuffer-contents 'minibuffer-contents)) + (eval-and-compile (defalias 'semantic-minibuffer-contents 'buffer-string))) +(if (fboundp 'delete-minibuffer-contents) + (eval-and-compile (defalias 'semantic-delete-minibuffer-contents 'delete-minibuffer-contents)) + (eval-and-compile (defalias 'semantic-delete-minibuffer-contents 'erase-buffer))) + +(defvar semantic-complete-inline-overlay nil + "The overlay currently active while completing inline.") + +(defun semantic-completion-inline-active-p () + "Non-nil if inline completion is active." + (when (and semantic-complete-inline-overlay + (not (semantic-overlay-live-p semantic-complete-inline-overlay))) + (semantic-overlay-delete semantic-complete-inline-overlay) + (setq semantic-complete-inline-overlay nil)) + semantic-complete-inline-overlay) + +;;; ------------------------------------------------------------ +;;; MINIBUFFER or INLINE utils +;; +(defun semantic-completion-text () + "Return the text that is currently in the completion buffer. +For a minibuffer prompt, this is the minibuffer text. +For inline completion, this is the text wrapped in the inline completion +overlay." + (if semantic-complete-inline-overlay + (semantic-complete-inline-text) + (semantic-minibuffer-contents))) + +(defun semantic-completion-delete-text () + "Delete the text that is actively being completed. +Presumably if you call this you will insert something new there." + (if semantic-complete-inline-overlay + (semantic-complete-inline-delete-text) + (semantic-delete-minibuffer-contents))) + +(defun semantic-completion-message (fmt &rest args) + "Display the string FMT formatted with ARGS at the end of the minibuffer." + (if semantic-complete-inline-overlay + (apply 'message fmt args) + (message (concat (buffer-string) (apply 'format fmt args))))) + +;;; ------------------------------------------------------------ +;;; MINIBUFFER: Option Selection harnesses +;; +(defvar semantic-completion-collector-engine nil + "The tag collector for the current completion operation. +Value should be an object of a subclass of +`semantic-completion-engine-abstract'.") + +(defvar semantic-completion-display-engine nil + "The tag display engine for the current completion operation. +Value should be a ... what?") + +(defvar semantic-complete-key-map + (let ((km (make-sparse-keymap))) + (define-key km " " 'semantic-complete-complete-space) + (define-key km "\t" 'semantic-complete-complete-tab) + (define-key km "\C-m" 'semantic-complete-done) + (define-key km "\C-g" 'abort-recursive-edit) + (define-key km "\M-n" 'next-history-element) + (define-key km "\M-p" 'previous-history-element) + (define-key km "\C-n" 'next-history-element) + (define-key km "\C-p" 'previous-history-element) + ;; Add history navigation + km) + "Keymap used while completing across a list of tags.") + +(defvar semantic-completion-default-history nil + "Default history variable for any unhistoried prompt. +Keeps STRINGS only in the history.") + + +(defun semantic-complete-read-tag-engine (collector displayor prompt + default-tag initial-input + history) + "Read a semantic tag, and return a tag for the selection. +Argument COLLECTOR is an object which can be used to to calculate +a list of possible hits. See `semantic-completion-collector-engine' +for details on COLLECTOR. +Argumeng DISPLAYOR is an object used to display a list of possible +completions for a given prefix. See`semantic-completion-display-engine' +for details on DISPLAYOR. +PROMPT is a string to prompt with. +DEFAULT-TAG is a semantic tag or string to use as the default value. +If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. +HISTORY is a symbol representing a variable to story the history in." + (let* ((semantic-completion-collector-engine collector) + (semantic-completion-display-engine displayor) + (semantic-complete-active-default nil) + (semantic-complete-current-matched-tag nil) + (default-as-tag (semantic-complete-default-to-tag default-tag)) + (default-as-string (when (semantic-tag-p default-as-tag) + (semantic-tag-name default-as-tag))) + ) + + (when default-as-string + ;; Add this to the prompt. + ;; + ;; I really want to add a lookup of the symbol in those + ;; tags available to the collector and only add it if it + ;; is available as a possibility, but I'm too lazy right + ;; now. + ;; + + ;; @todo - move from () to into the editable area + (if (string-match ":" prompt) + (setq prompt (concat + (substring prompt 0 (match-beginning 0)) + " (" default-as-string ")" + (substring prompt (match-beginning 0)))) + (setq prompt (concat prompt " (" default-as-string "): ")))) + ;; + ;; Perform the Completion + ;; + (unwind-protect + (read-from-minibuffer prompt + initial-input + semantic-complete-key-map + nil + (or history + 'semantic-completion-default-history) + default-tag) + (semantic-collector-cleanup semantic-completion-collector-engine) + (semantic-displayor-cleanup semantic-completion-display-engine) + ) + ;; + ;; Extract the tag from the completion machinery. + ;; + semantic-complete-current-matched-tag + )) + + +;;; Util for basic completion prompts +;; + +(defvar semantic-complete-active-default nil + "The current default tag calculated for this prompt.") + +(defun semantic-complete-default-to-tag (default) + "Convert a calculated or passed in DEFAULT into a tag." + (if (semantic-tag-p default) + ;; Just return what was passed in. + (setq semantic-complete-active-default default) + ;; If none was passed in, guess. + (if (null default) + (setq default (semantic-ctxt-current-thing))) + (if (null default) + ;; Do nothing + nil + ;; Turn default into something useful. + (let ((str + (cond + ;; Semantic-ctxt-current-symbol will return a list of + ;; strings. Technically, we should use the analyzer to + ;; fully extract what we need, but for now, just grab the + ;; first string + ((and (listp default) (stringp (car default))) + (car default)) + ((stringp default) + default) + ((symbolp default) + (symbol-name default)) + (t + (signal 'wrong-type-argument + (list default 'semantic-tag-p))))) + (tag nil)) + ;; Now that we have that symbol string, look it up using the active + ;; collector. If we get a match, use it. + (save-excursion + (semantic-collector-calculate-completions + semantic-completion-collector-engine + str nil)) + ;; Do we have the perfect match??? + (let ((ml (semantic-collector-current-exact-match + semantic-completion-collector-engine))) + (when ml + ;; We don't care about uniqueness. Just guess for convenience + (setq tag (semanticdb-find-result-nth-in-buffer ml 0)))) + ;; save it + (setq semantic-complete-active-default tag) + ;; Return it.. .whatever it may be + tag)))) + + +;;; Prompt Return Value +;; +;; Getting a return value out of this completion prompt is a bit +;; challenging. The read command returns the string typed in. +;; We need to convert this into a valid tag. We can exit the minibuffer +;; for different reasons. If we purposely exit, we must make sure +;; the focused tag is calculated... preferably once. +(defvar semantic-complete-current-matched-tag nil + "Variable used to pass the tags being matched to the prompt.") + +(defun semantic-complete-current-match () + "Calculate a match from the current completion environment. +Save this in our completion variable. Make sure that variable +is cleared if any other keypress is made. +Return value can be: + tag - a single tag that has been matched. + string - a message to show in the minibuffer." + ;; Query the environment for an active completion. + (let ((collector semantic-completion-collector-engine) + (displayor semantic-completion-display-engine) + (contents (semantic-completion-text)) + matchlist + answer) + (if (string= contents "") + ;; The user wants the defaults! + (setq answer semantic-complete-active-default) + ;; This forces a full calculation of completion on CR. + (save-excursion + (semantic-collector-calculate-completions collector contents nil)) + (semantic-complete-try-completion) + (cond + ;; Input match displayor focus entry + ((setq answer (semantic-displayor-current-focus displayor)) + ;; We have answer, continue + ) + ;; One match from the collector + ((setq matchlist (semantic-collector-current-exact-match collector)) + (if (= (semanticdb-find-result-length matchlist) 1) + (setq answer (semanticdb-find-result-nth-in-buffer matchlist 0)) + (if (semantic-displayor-focus-abstract-child-p displayor) + ;; For focusing displayors, we can claim this is + ;; not unique. Multiple focuses can choose the correct + ;; one. + (setq answer "Not Unique") + ;; If we don't have a focusing displayor, we need to do something + ;; graceful. First, see if all the matches have the same name. + (let ((allsame t) + (firstname (semantic-tag-name + (car + (semanticdb-find-result-nth matchlist 0))) + ) + (cnt 1) + (max (semanticdb-find-result-length matchlist))) + (while (and allsame (< cnt max)) + (if (not (string= + firstname + (semantic-tag-name + (car + (semanticdb-find-result-nth matchlist cnt))))) + (setq allsame nil)) + (setq cnt (1+ cnt)) + ) + ;; Now we know if they are all the same. If they are, just + ;; accept the first, otherwise complain. + (if allsame + (setq answer (semanticdb-find-result-nth-in-buffer + matchlist 0)) + (setq answer "Not Unique")) + )))) + ;; No match + (t + (setq answer "No Match"))) + ) + ;; Set it into our completion target. + (when (semantic-tag-p answer) + (setq semantic-complete-current-matched-tag answer) + ;; Make sure it is up to date by clearing it if the user dares + ;; to touch the keyboard. + (add-hook 'pre-command-hook + (lambda () (setq semantic-complete-current-matched-tag nil))) + ) + ;; Return it + answer + )) + + +;;; Keybindings +;; +;; Keys are bound to to perform completion using our mechanisms. +;; Do that work here. +(defun semantic-complete-done () + "Accept the current input." + (interactive) + (let ((ans (semantic-complete-current-match))) + (if (stringp ans) + (semantic-completion-message (concat " [" ans "]")) + (exit-minibuffer))) + ) + +(defun semantic-complete-complete-space () + "Complete the partial input in the minibuffer." + (interactive) + (semantic-complete-do-completion t)) + +(defun semantic-complete-complete-tab () + "Complete the partial input in the minibuffer as far as possible." + (interactive) + (semantic-complete-do-completion)) + +;;; Completion Functions +;; +;; Thees routines are functional entry points to performing completion. +;; +(defun semantic-complete-hack-word-boundaries (original new) + "Return a string to use for completion. +ORIGINAL is the text in the minibuffer. +NEW is the new text to insert into the minibuffer. +Within the difference bounds of ORIGINAL and NEW, shorten NEW +to the nearest word boundary, and return that." + (save-match-data + (let* ((diff (substring new (length original))) + (end (string-match "\\>" diff)) + (start (string-match "\\<" diff))) + (cond + ((and start (> start 0)) + ;; If start is greater than 0, include only the new + ;; white-space stuff + (concat original (substring diff 0 start))) + (end + (concat original (substring diff 0 end))) + (t new))))) + +(defun semantic-complete-try-completion (&optional partial) + "Try a completion for the current minibuffer. +If PARTIAL, do partial completion stopping at spaces." + (let ((comp (semantic-collector-try-completion + semantic-completion-collector-engine + (semantic-completion-text)))) + (cond + ((null comp) + (semantic-completion-message " [No Match]") + (ding) + ) + ((stringp comp) + (if (string= (semantic-completion-text) comp) + (when partial + ;; Minibuffer isn't changing AND the text is not unique. + ;; Test for partial completion over a word separator character. + ;; If there is one available, use that so that SPC can + ;; act like a SPC insert key. + (let ((newcomp (semantic-collector-current-whitespace-completion + semantic-completion-collector-engine))) + (when newcomp + (semantic-completion-delete-text) + (insert newcomp)) + )) + (when partial + (let ((orig (semantic-completion-text))) + ;; For partial completion, we stop and step over + ;; word boundaries. Use this nifty function to do + ;; that calculation for us. + (setq comp + (semantic-complete-hack-word-boundaries orig comp)))) + ;; Do the replacement. + (semantic-completion-delete-text) + (insert comp)) + ) + ((and (listp comp) (semantic-tag-p (car comp))) + (unless (string= (semantic-completion-text) + (semantic-tag-name (car comp))) + ;; A fully unique completion was available. + (semantic-completion-delete-text) + (insert (semantic-tag-name (car comp)))) + ;; The match is complete + (if (= (length comp) 1) + (semantic-completion-message " [Complete]") + (semantic-completion-message " [Complete, but not unique]")) + ) + (t nil)))) + +(defun semantic-complete-do-completion (&optional partial inline) + "Do a completion for the current minibuffer. +If PARTIAL, do partial completion stopping at spaces. +if INLINE, then completion is happening inline in a buffer." + (let* ((collector semantic-completion-collector-engine) + (displayor semantic-completion-display-engine) + (contents (semantic-completion-text)) + (ans nil)) + + (save-excursion + (semantic-collector-calculate-completions collector contents partial)) + (let* ((na (semantic-complete-next-action partial))) + (cond + ;; We're all done, but only from a very specific + ;; area of completion. + ((eq na 'done) + (semantic-completion-message " [Complete]") + (setq ans 'done)) + ;; Perform completion + ((or (eq na 'complete) + (eq na 'complete-whitespace)) + (semantic-complete-try-completion partial) + (setq ans 'complete)) + ;; We need to display the completions. + ;; Set the completions into the display engine + ((or (eq na 'display) (eq na 'displayend)) + (semantic-displayor-set-completions + displayor + (or + (and (not (eq na 'displayend)) + (semantic-collector-current-exact-match collector)) + (semantic-collector-all-completions collector contents)) + contents) + ;; Ask the displayor to display them. + (semantic-displayor-show-request displayor)) + ((eq na 'scroll) + (semantic-displayor-scroll-request displayor) + ) + ((eq na 'focus) + (semantic-displayor-focus-next displayor) + (semantic-displayor-focus-request displayor) + ) + ((eq na 'empty) + (semantic-completion-message " [No Match]")) + (t nil))) + ans)) + + +;;; ------------------------------------------------------------ +;;; INLINE: tag completion harness +;; +;; Unlike the minibuffer, there is no mode nor other traditional +;; means of reading user commands in completion mode. Instead +;; we use a pre-command-hook to inset in our commands, and to +;; push ourselves out of this mode on alternate keypresses. +(defvar semantic-complete-inline-map + (let ((km (make-sparse-keymap))) + (define-key km "\C-i" 'semantic-complete-inline-TAB) + (define-key km "\M-p" 'semantic-complete-inline-up) + (define-key km "\M-n" 'semantic-complete-inline-down) + (define-key km "\C-m" 'semantic-complete-inline-done) + (define-key km "\C-\M-c" 'semantic-complete-inline-exit) + (define-key km "\C-g" 'semantic-complete-inline-quit) + (define-key km "?" + (lambda () (interactive) + (describe-variable 'semantic-complete-inline-map))) + km) + "Keymap used while performing Semantic inline completion. +\\{semantic-complete-inline-map}") + +(defface semantic-complete-inline-face + '((((class color) (background dark)) + (:underline "yellow")) + (((class color) (background light)) + (:underline "brown"))) + "*Face used to show the region being completed inline. +The face is used in `semantic-complete-inline-tag-engine'." + :group 'semantic-faces) + +(defun semantic-complete-inline-text () + "Return the text that is being completed inline. +Similar to `minibuffer-contents' when completing in the minibuffer." + (let ((s (semantic-overlay-start semantic-complete-inline-overlay)) + (e (semantic-overlay-end semantic-complete-inline-overlay))) + (if (= s e) + "" + (buffer-substring-no-properties s e )))) + +(defun semantic-complete-inline-delete-text () + "Delete the text currently being completed in the current buffer." + (delete-region + (semantic-overlay-start semantic-complete-inline-overlay) + (semantic-overlay-end semantic-complete-inline-overlay))) + +(defun semantic-complete-inline-done () + "This completion thing is DONE, OR, insert a newline." + (interactive) + (let* ((displayor semantic-completion-display-engine) + (tag (semantic-displayor-current-focus displayor))) + (if tag + (let ((txt (semantic-completion-text))) + (insert (substring (semantic-tag-name tag) + (length txt))) + (semantic-complete-inline-exit)) + + ;; Get whatever binding RET usually has. + (let ((fcn + (condition-case nil + (lookup-key (current-active-maps) (this-command-keys)) + (error + ;; I don't know why, but for some reason the above + ;; throws an error sometimes. + (lookup-key (current-global-map) (this-command-keys)) + )))) + (when fcn + (funcall fcn))) + ))) + +(defun semantic-complete-inline-quit () + "Quit an inline edit." + (interactive) + (semantic-complete-inline-exit) + (keyboard-quit)) + +(defun semantic-complete-inline-exit () + "Exit inline completion mode." + (interactive) + ;; Remove this hook FIRST! + (remove-hook 'pre-command-hook 'semantic-complete-pre-command-hook) + + (condition-case nil + (progn + (when semantic-completion-collector-engine + (semantic-collector-cleanup semantic-completion-collector-engine)) + (when semantic-completion-display-engine + (semantic-displayor-cleanup semantic-completion-display-engine)) + + (when semantic-complete-inline-overlay + (let ((wc (semantic-overlay-get semantic-complete-inline-overlay + 'window-config-start)) + (buf (semantic-overlay-buffer semantic-complete-inline-overlay)) + ) + (semantic-overlay-delete semantic-complete-inline-overlay) + (setq semantic-complete-inline-overlay nil) + ;; DONT restore the window configuration if we just + ;; switched windows! + (when (eq buf (current-buffer)) + (set-window-configuration wc)) + )) + + (setq semantic-completion-collector-engine nil + semantic-completion-display-engine nil)) + (error nil)) + + ;; Remove this hook LAST!!! + ;; This will force us back through this function if there was + ;; some sort of error above. + (remove-hook 'post-command-hook 'semantic-complete-post-command-hook) + + ;;(message "Exiting inline completion.") + ) + +(defun semantic-complete-pre-command-hook () + "Used to redefine what commands are being run while completing. +When installed as a `pre-command-hook' the special keymap +`semantic-complete-inline-map' is queried to replace commands normally run. +Commands which edit what is in the region of interest operate normally. +Commands which would take us out of the region of interest, or our +quit hook, will exit this completion mode." + (let ((fcn (lookup-key semantic-complete-inline-map + (this-command-keys) nil))) + (cond ((commandp fcn) + (setq this-command fcn)) + (t nil))) + ) + +(defun semantic-complete-post-command-hook () + "Used to determine if we need to exit inline completion mode. +If completion mode is active, check to see if we are within +the bounds of `semantic-complete-inline-overlay', or within +a reasonable distance." + (condition-case nil + ;; Exit if something bad happened. + (if (not semantic-complete-inline-overlay) + (progn + ;;(message "Inline Hook installed, but overlay deleted.") + (semantic-complete-inline-exit)) + ;; Exit if commands caused us to exit the area of interest + (let ((s (semantic-overlay-start semantic-complete-inline-overlay)) + (e (semantic-overlay-end semantic-complete-inline-overlay)) + (b (semantic-overlay-buffer semantic-complete-inline-overlay)) + (txt nil) + ) + (cond + ;; EXIT when we are no longer in a good place. + ((or (not (eq b (current-buffer))) + (< (point) s) + (> (point) e)) + ;;(message "Exit: %S %S %S" s e (point)) + (semantic-complete-inline-exit) + ) + ;; Exit if the user typed in a character that is not part + ;; of the symbol being completed. + ((and (setq txt (semantic-completion-text)) + (not (string= txt "")) + (and (/= (point) s) + (save-excursion + (forward-char -1) + (not (looking-at "\\(\\w\\|\\s_\\)"))))) + ;;(message "Non symbol character.") + (semantic-complete-inline-exit)) + ((lookup-key semantic-complete-inline-map + (this-command-keys) nil) + ;; If the last command was one of our completion commands, + ;; then do nothing. + nil + ) + (t + ;; Else, show completions now + (semantic-complete-inline-force-display) + + )))) + ;; If something goes terribly wrong, clean up after ourselves. + (error (semantic-complete-inline-exit)))) + +(defun semantic-complete-inline-force-display () + "Force the display of whatever the current completions are. +DO NOT CALL THIS IF THE INLINE COMPLETION ENGINE IS NOT ACTIVE." + (condition-case e + (save-excursion + (let ((collector semantic-completion-collector-engine) + (displayor semantic-completion-display-engine) + (contents (semantic-completion-text))) + (when collector + (semantic-collector-calculate-completions + collector contents nil) + (semantic-displayor-set-completions + displayor + (semantic-collector-all-completions collector contents) + contents) + ;; Ask the displayor to display them. + (semantic-displayor-show-request displayor)) + )) + (error (message "Bug Showing Completions: %S" e)))) + +(defun semantic-complete-inline-tag-engine + (collector displayor buffer start end) + "Perform completion based on semantic tags in a buffer. +Argument COLLECTOR is an object which can be used to to calculate +a list of possible hits. See `semantic-completion-collector-engine' +for details on COLLECTOR. +Argumeng DISPLAYOR is an object used to display a list of possible +completions for a given prefix. See`semantic-completion-display-engine' +for details on DISPLAYOR. +BUFFER is the buffer in which completion will take place. +START is a location for the start of the full symbol. +If the symbol being completed is \"foo.ba\", then START +is on the \"f\" character. +END is at the end of the current symbol being completed." + ;; Set us up for doing completion + (setq semantic-completion-collector-engine collector + semantic-completion-display-engine displayor) + ;; Create an overlay + (setq semantic-complete-inline-overlay + (semantic-make-overlay start end buffer nil t)) + (semantic-overlay-put semantic-complete-inline-overlay + 'face + 'semantic-complete-inline-face) + (semantic-overlay-put semantic-complete-inline-overlay + 'window-config-start + (current-window-configuration)) + ;; Install our command hooks + (add-hook 'pre-command-hook 'semantic-complete-pre-command-hook) + (add-hook 'post-command-hook 'semantic-complete-post-command-hook) + ;; Go! + (semantic-complete-inline-force-display) + ) + +;;; Inline Completion Keymap Functions +;; +(defun semantic-complete-inline-TAB () + "Perform inline completion." + (interactive) + (let ((cmpl (semantic-complete-do-completion nil t))) + (cond + ((eq cmpl 'complete) + (semantic-complete-inline-force-display)) + ((eq cmpl 'done) + (semantic-complete-inline-done)) + )) + ) + +(defun semantic-complete-inline-down() + "Focus forwards through the displayor." + (interactive) + (let ((displayor semantic-completion-display-engine)) + (semantic-displayor-focus-next displayor) + (semantic-displayor-focus-request displayor) + )) + +(defun semantic-complete-inline-up () + "Focus backwards through the displayor." + (interactive) + (let ((displayor semantic-completion-display-engine)) + (semantic-displayor-focus-previous displayor) + (semantic-displayor-focus-request displayor) + )) + + +;;; ------------------------------------------------------------ +;;; Interactions between collection and displaying +;; +;; Functional routines used to help collectors communicate with +;; the current displayor, or for the previous section. + +(defun semantic-complete-next-action (partial) + "Determine what the next completion action should be. +PARTIAL is non-nil if we are doing partial completion. +First, the collector can determine if we should perform a completion or not. +If there is nothing to complete, then the displayor determines if we are +to show a completion list, scroll, or perhaps do a focus (if it is capable.) +Expected return values are: + done -> We have a singular match + empty -> There are no matches to the current text + complete -> Perform a completion action + complete-whitespace -> Complete next whitespace type character. + display -> Show the list of completions + scroll -> The completions have been shown, and the user keeps hitting + the complete button. If possible, scroll the completions + focus -> The displayor knows how to shift focus among possible completions. + Let it do that. + displayend -> Whatever options the displayor had for repeating options, there + are none left. Try something new." + (let ((ans1 (semantic-collector-next-action + semantic-completion-collector-engine + partial)) + (ans2 (semantic-displayor-next-action + semantic-completion-display-engine)) + ) + (cond + ;; No collector answer, use displayor answer. + ((not ans1) + ans2) + ;; Displayor selection of 'scroll, 'display, or 'focus trumps + ;; 'done + ((and (eq ans1 'done) ans2) + ans2) + ;; Use ans1 when we have it. + (t + ans1)))) + + + +;;; ------------------------------------------------------------ +;;; Collection Engines +;; +;; Collection engines can scan tags from the current environment and +;; provide lists of possible completions. +;; +;; General features of the abstract collector: +;; * Cache completion lists between uses +;; * Cache itself per buffer. Handle reparse hooks +;; +;; Key Interface Functions to implement: +;; * semantic-collector-next-action +;; * semantic-collector-calculate-completions +;; * semantic-collector-try-completion +;; * semantic-collector-all-completions + +(defvar semantic-collector-per-buffer-list nil + "List of collectors active in this buffer.") +(make-variable-buffer-local 'semantic-collector-per-buffer-list) + +(defvar semantic-collector-list nil + "List of global collectors active this session.") + +(defclass semantic-collector-abstract () + ((buffer :initarg :buffer + :type buffer + :documentation "Originating buffer for this collector. +Some collectors use a given buffer as a starting place while looking up +tags.") + (cache :initform nil + :type (or null semanticdb-find-result-with-nil) + :documentation "Cache of tags. +These tags are re-used during a completion session. +Sometimes these tags are cached between completion sessions.") + (last-all-completions :initarg nil + :type semanticdb-find-result-with-nil + :documentation "Last result of `all-completions'. +This result can be used for refined completions as `last-prefix' gets +closer to a specific result.") + (last-prefix :type string + :protection :protected + :documentation "The last queried prefix. +This prefix can be used to cache intermediate completion offers. +making the action of homing in on a token faster.") + (last-completion :type (or null string) + :documentation "The last calculated completion. +This completion is calculated and saved for future use.") + (last-whitespace-completion :type (or null string) + :documentation "The last whitespace completion. +For partial completion, SPC will disabiguate over whitespace type +characters. This is the last calculated version.") + (current-exact-match :type list + :protection :protected + :documentation "The list of matched tags. +When tokens are matched, they are added to this list.") + ) + "Root class for completion engines. +The baseclass provides basic functionality for interacting with +a completion displayor object, and tracking the current progress +of a completion." + :abstract t) + +(defmethod semantic-collector-cleanup ((obj semantic-collector-abstract)) + "Clean up any mess this collector may have." + nil) + +(defmethod semantic-collector-next-action + ((obj semantic-collector-abstract) partial) + "What should we do next? OBJ can predict a next good action. +PARTIAL indicates if we are doing a partial completion." + (if (and (slot-boundp obj 'last-completion) + (string= (semantic-completion-text) (oref obj last-completion))) + (let* ((cem (semantic-collector-current-exact-match obj)) + (cemlen (semanticdb-find-result-length cem)) + (cac (semantic-collector-all-completions + obj (semantic-completion-text))) + (caclen (semanticdb-find-result-length cac))) + (cond ((and cem (= cemlen 1) + cac (> caclen 1) + (eq last-command this-command)) + ;; Defer to the displayor... + nil) + ((and cem (= cemlen 1)) + 'done) + ((and (not cem) (not cac)) + 'empty) + ((and partial (semantic-collector-try-completion-whitespace + obj (semantic-completion-text))) + 'complete-whitespace))) + 'complete)) + +(defmethod semantic-collector-last-prefix= ((obj semantic-collector-abstract) + last-prefix) + "Return non-nil if OBJ's prefix matches PREFIX." + (and (slot-boundp obj 'last-prefix) + (string= (oref obj last-prefix) last-prefix))) + +(defmethod semantic-collector-get-cache ((obj semantic-collector-abstract)) + "Get the raw cache of tags for completion. +Calculate the cache if there isn't one." + (or (oref obj cache) + (semantic-collector-calculate-cache obj))) + +(defmethod semantic-collector-calculate-completions-raw + ((obj semantic-collector-abstract) prefix completionlist) + "Calculate the completions for prefix from completionlist. +Output must be in semanticdb Find result format." + ;; Must output in semanticdb format + (let ((table (save-excursion + (set-buffer (oref obj buffer)) + semanticdb-current-table)) + (result (semantic-find-tags-for-completion + prefix + ;; To do this kind of search with a pre-built completion + ;; list, we need to strip it first. + (semanticdb-strip-find-results completionlist))) + ) + (if result + (list (cons table result))))) + +(defmethod semantic-collector-calculate-completions + ((obj semantic-collector-abstract) prefix partial) + "Calculate completions for prefix as setup for other queries." + (let* ((case-fold-search semantic-case-fold) + (same-prefix-p (semantic-collector-last-prefix= obj prefix)) + (completionlist + (if (or same-prefix-p + (and (slot-boundp obj 'last-prefix) + (eq (compare-strings (oref obj last-prefix) 0 nil + prefix 0 (length prefix)) + t))) + ;; New prefix is subset of old prefix + (oref obj last-all-completions) + (semantic-collector-get-cache obj))) + ;; Get the result + (answer (if same-prefix-p + completionlist + (semantic-collector-calculate-completions-raw + obj prefix completionlist)) + ) + (completion nil) + (complete-not-uniq nil) + ) + ;;(semanticdb-find-result-test answer) + (when (not same-prefix-p) + ;; Save results if it is interesting and beneficial + (oset obj last-prefix prefix) + (oset obj last-all-completions answer)) + ;; Now calculate the completion. + (setq completion (try-completion + prefix + (semanticdb-strip-find-results answer))) + (oset obj last-whitespace-completion nil) + (oset obj current-exact-match nil) + ;; Only do this if a completion was found. Letting a nil in + ;; could cause a full semanticdb search by accident. + (when completion + (oset obj last-completion + (cond + ;; Unique match in AC. Last completion is a match. + ;; Also set the current-exact-match. + ((eq completion t) + (oset obj current-exact-match answer) + prefix) + ;; It may be complete (a symbol) but still not unique. + ;; We can capture a match + ((setq complete-not-uniq + (semanticdb-find-tags-by-name + prefix + answer)) + (oset obj current-exact-match + complete-not-uniq) + prefix + ) + ;; Non unique match, return the string that handles + ;; completion + (t (or completion prefix)) + ))) + )) + +(defmethod semantic-collector-try-completion-whitespace + ((obj semantic-collector-abstract) prefix) + "For OBJ, do whatepsace completion based on PREFIX. +This implies that if there are two completions, one matching +the test \"preifx\\>\", and one not, the one matching the full +word version of PREFIX will be chosen, and that text returned. +This function requires that `semantic-collector-calculate-completions' +has been run first." + (let* ((ac (semantic-collector-all-completions obj prefix)) + (matchme (concat "^" prefix "\\>")) + (compare (semanticdb-find-tags-by-name-regexp matchme ac)) + (numtag (semanticdb-find-result-length compare)) + ) + (if compare + (let* ((idx 0) + (cutlen (1+ (length prefix))) + (twws (semanticdb-find-result-nth compare idx))) + ;; Is our tag with whitespace a match that has whitespace + ;; after it, or just an already complete symbol? + (while (and (< idx numtag) + (< (length (semantic-tag-name (car twws))) cutlen)) + (setq idx (1+ idx) + twws (semanticdb-find-result-nth compare idx))) + (when (and twws (car-safe twws)) + ;; If COMPARE has succeeded, then we should take the very + ;; first match, and extend prefix by one character. + (oset obj last-whitespace-completion + (substring (semantic-tag-name (car twws)) + 0 cutlen)))) + ))) + + +(defmethod semantic-collector-current-exact-match ((obj semantic-collector-abstract)) + "Return the active valid MATCH from the semantic collector. +For now, just return the first element from our list of available +matches. For semanticdb based results, make sure the file is loaded +into a buffer." + (when (slot-boundp obj 'current-exact-match) + (oref obj current-exact-match))) + +(defmethod semantic-collector-current-whitespace-completion ((obj semantic-collector-abstract)) + "Return the active whitespace completion value." + (when (slot-boundp obj 'last-whitespace-completion) + (oref obj last-whitespace-completion))) + +(defmethod semantic-collector-get-match ((obj semantic-collector-abstract)) + "Return the active valid MATCH from the semantic collector. +For now, just return the first element from our list of available +matches. For semanticdb based results, make sure the file is loaded +into a buffer." + (when (slot-boundp obj 'current-exact-match) + (semanticdb-find-result-nth-in-buffer (oref obj current-exact-match) 0))) + +(defmethod semantic-collector-all-completions + ((obj semantic-collector-abstract) prefix) + "For OBJ, retrieve all completions matching PREFIX. +The returned list consists of all the tags currently +matching PREFIX." + (when (slot-boundp obj 'last-all-completions) + (oref obj last-all-completions))) + +(defmethod semantic-collector-try-completion + ((obj semantic-collector-abstract) prefix) + "For OBJ, attempt to match PREFIX. +See `try-completion' for details on how this works. +Return nil for no match. +Return a string for a partial match. +For a unique match of PREFIX, return the list of all tags +with that name." + (if (slot-boundp obj 'last-completion) + (oref obj last-completion))) + +(defmethod semantic-collector-calculate-cache + ((obj semantic-collector-abstract)) + "Calculate the completion cache for OBJ." + nil + ) + +(defmethod semantic-collector-flush ((this semantic-collector-abstract)) + "Flush THIS collector object, clearing any caches and prefix." + (oset this cache nil) + (slot-makeunbound this 'last-prefix) + (slot-makeunbound this 'last-completion) + (slot-makeunbound this 'last-all-completions) + (slot-makeunbound this 'current-exact-match) + ) + +;;; PER BUFFER +;; +(defclass semantic-collector-buffer-abstract (semantic-collector-abstract) + () + "Root class for per-buffer completion engines. +These collectors track themselves on a per-buffer basis." + :abstract t) + +(defmethod constructor :STATIC ((this semantic-collector-buffer-abstract) + newname &rest fields) + "Reuse previously created objects of this type in buffer." + (let ((old nil) + (bl semantic-collector-per-buffer-list)) + (while (and bl (null old)) + (if (eq (object-class (car bl)) this) + (setq old (car bl)))) + (unless old + (let ((new (call-next-method))) + (add-to-list 'semantic-collector-per-buffer-list new) + (setq old new))) + (slot-makeunbound old 'last-completion) + (slot-makeunbound old 'last-prefix) + (slot-makeunbound old 'current-exact-match) + old)) + +;; Buffer specific collectors should flush themselves +(defun semantic-collector-buffer-flush (newcache) + "Flush all buffer collector objects. +NEWCACHE is the new tag table, but we ignore it." + (condition-case nil + (let ((l semantic-collector-per-buffer-list)) + (while l + (if (car l) (semantic-collector-flush (car l))) + (setq l (cdr l)))) + (error nil))) + +(add-hook 'semantic-after-toplevel-cache-change-hook + 'semantic-collector-buffer-flush) + +;;; DEEP BUFFER SPECIFIC COMPLETION +;; +(defclass semantic-collector-buffer-deep + (semantic-collector-buffer-abstract) + () + "Completion engine for tags in the current buffer. +When searching for a tag, uses semantic deep searche functions. +Basics search only in the current buffer.") + +(defmethod semantic-collector-calculate-cache + ((obj semantic-collector-buffer-deep)) + "Calculate the completion cache for OBJ. +Uses `semantic-flatten-tags-table'" + (oset obj cache + ;; Must create it in SEMANTICDB find format. + ;; ( ( DBTABLE TAG TAG ... ) ... ) + (list + (cons semanticdb-current-table + (semantic-flatten-tags-table (oref obj buffer)))))) + +;;; PROJECT SPECIFIC COMPLETION +;; +(defclass semantic-collector-project-abstract (semantic-collector-abstract) + ((path :initarg :path + :initform nil + :documentation "List of database tables to search. +At creation time, it can be anything accepted by +`semanticdb-find-translate-path' as a PATH argument.") + ) + "Root class for project wide completion engines. +Uses semanticdb for searching all tags in the current project." + :abstract t) + +;;; Project Search +(defclass semantic-collector-project (semantic-collector-project-abstract) + () + "Completion engine for tags in a project.") + + +(defmethod semantic-collector-calculate-completions-raw + ((obj semantic-collector-project) prefix completionlist) + "Calculate the completions for prefix from completionlist." + (semanticdb-find-tags-for-completion prefix (oref obj path))) + +;;; Brutish Project search +(defclass semantic-collector-project-brutish (semantic-collector-project-abstract) + () + "Completion engine for tags in a project.") + +(defmethod semantic-collector-calculate-completions-raw + ((obj semantic-collector-project-brutish) prefix completionlist) + "Calculate the completions for prefix from completionlist." + (semanticdb-brute-deep-find-tags-for-completion prefix (oref obj path))) + +(defclass semantic-collector-analyze-completions (semantic-collector-abstract) + ((context :initarg :context + :type semantic-analyze-context + :documentation "An analysis context. +Specifies some context location from whence completion lists will be drawn." + ) + (first-pass-completions :type list + :documentation "List of valid completion tags. +This list of tags is generated when completion starts. All searches +derive from this list.") + ) + "Completion engine that uses the context analyzer to provide options. +The only options available for completion are those which can be logically +inserted into the current context.") + +(defmethod semantic-collector-calculate-completions-raw + ((obj semantic-collector-analyze-completions) prefix completionlist) + "calculate the completions for prefix from completionlist." + ;; if there are no completions yet, calculate them. + (if (not (slot-boundp obj 'first-pass-completions)) + (oset obj first-pass-completions + (semantic-analyze-possible-completions (oref obj context)))) + ;; search our cached completion list. make it look like a semanticdb + ;; results type. + (list (cons (save-excursion + (set-buffer (oref (oref obj context) buffer)) + semanticdb-current-table) + (semantic-find-tags-for-completion + prefix + (oref obj first-pass-completions))))) + + +;;; ------------------------------------------------------------ +;;; Tag List Display Engines +;; +;; A typical displayor accepts a pre-determined list of completions +;; generated by a collector. This format is in semanticdb search +;; form. This vaguely standard form is a bit challenging to navigate +;; because the tags do not contain buffer info, but the file assocated +;; with the tags preceed the tag in the list. +;; +;; Basic displayors don't care, and can strip the results. +;; Advanced highlighting displayors need to know when they need +;; to load a file so that the tag in question can be highlighted. +;; +;; Key interface methods to a displayor are: +;; * semantic-displayor-next-action +;; * semantic-displayor-set-completions +;; * semantic-displayor-current-focus +;; * semantic-displayor-show-request +;; * semantic-displayor-scroll-request +;; * semantic-displayor-focus-request + +(defclass semantic-displayor-abstract () + ((table :type (or null semanticdb-find-result-with-nil) + :initform nil + :protection :protected + :documentation "List of tags this displayor is showing.") + (last-prefix :type string + :protection :protected + :documentation "Prefix associated with slot `table'") + ) + "Abstract displayor baseclass. +Manages the display of some number of tags. +Provides the basics for a displayor, including interacting with +a collector, and tracking tables of completion to display." + :abstract t) + +(defmethod semantic-displayor-cleanup ((obj semantic-displayor-abstract)) + "Clean up any mess this displayor may have." + nil) + +(defmethod semantic-displayor-next-action ((obj semantic-displayor-abstract)) + "The next action to take on the minibuffer related to display." + (if (and (slot-boundp obj 'last-prefix) + (string= (oref obj last-prefix) (semantic-completion-text)) + (eq last-command this-command)) + 'scroll + 'display)) + +(defmethod semantic-displayor-set-completions ((obj semantic-displayor-abstract) + table prefix) + "Set the list of tags to be completed over to TABLE." + (oset obj table table) + (oset obj last-prefix prefix)) + +(defmethod semantic-displayor-show-request ((obj semantic-displayor-abstract)) + "A request to show the current tags table." + (ding)) + +(defmethod semantic-displayor-focus-request ((obj semantic-displayor-abstract)) + "A request to for the displayor to focus on some tag option." + (ding)) + +(defmethod semantic-displayor-scroll-request ((obj semantic-displayor-abstract)) + "A request to for the displayor to scroll the completion list (if needed)." + (scroll-other-window)) + +(defmethod semantic-displayor-focus-previous ((obj semantic-displayor-abstract)) + "Set the current focus to the previous item." + nil) + +(defmethod semantic-displayor-focus-next ((obj semantic-displayor-abstract)) + "Set the current focus to the next item." + nil) + +(defmethod semantic-displayor-current-focus ((obj semantic-displayor-abstract)) + "Return a single tag currently in focus. +This object type doesn't do focus, so will never have a focus object." + nil) + +;; Traditional displayor +(defcustom semantic-completion-displayor-format-tag-function + #'semantic-format-tag-name + "*A Tag format function to use when showing completions." + :group 'semantic + :type semantic-format-tag-custom-list) + +(defclass semantic-displayor-traditional (semantic-displayor-abstract) + () + "Display options in *Completions* buffer. +Traditional display mechanism for a list of possible completions. +Completions are showin in a new buffer and listed with the ability +to click on the items to aid in completion.") + +(defmethod semantic-displayor-show-request ((obj semantic-displayor-traditional)) + "A request to show the current tags table." + + ;; NOTE TO SELF. Find the character to type next, and emphesize it. + + (with-output-to-temp-buffer "*Completions*" + (display-completion-list + (mapcar semantic-completion-displayor-format-tag-function + (semanticdb-strip-find-results (oref obj table)))) + ) + ) + +;;; Abstract baseclass for any displayor which supports focus +(defclass semantic-displayor-focus-abstract (semantic-displayor-abstract) + ((focus :type number + :protection :protected + :documentation "A tag index from `table' which has focus. +Multiple calls to the display function can choose to focus on a +given tag, by highlighting its location.") + (find-file-focus + :allocation :class + :initform nil + :documentation + "Non-nil if focusing requires a tag's buffer be in memory.") + ) + "Abstract displayor supporting `focus'. +A displayor which has the ability to focus in on one tag. +Focusing is a way of differentiationg between multiple tags +which have the same name." + :abstract t) + +(defmethod semantic-displayor-next-action ((obj semantic-displayor-focus-abstract)) + "The next action to take on the minibuffer related to display." + (if (and (slot-boundp obj 'last-prefix) + (string= (oref obj last-prefix) (semantic-completion-text)) + (eq last-command this-command)) + (if (and + (slot-boundp obj 'focus) + (slot-boundp obj 'table) + (<= (semanticdb-find-result-length (oref obj table)) + (1+ (oref obj focus)))) + ;; We are at the end of the focus road. + 'displayend + ;; Focus on some item. + 'focus) + 'display)) + +(defmethod semantic-displayor-set-completions ((obj semantic-displayor-focus-abstract) + table prefix) + "Set the list of tags to be completed over to TABLE." + (call-next-method) + (slot-makeunbound obj 'focus)) + +(defmethod semantic-displayor-focus-previous ((obj semantic-displayor-focus-abstract)) + "Set the current focus to the previous item. +Not meaningful return value." + (when (and (slot-boundp obj 'table) (oref obj table)) + (with-slots (table) obj + (if (or (not (slot-boundp obj 'focus)) + (<= (oref obj focus) 0)) + (oset obj focus (1- (semanticdb-find-result-length table))) + (oset obj focus (1- (oref obj focus))) + ) + ))) + +(defmethod semantic-displayor-focus-next ((obj semantic-displayor-focus-abstract)) + "Set the current focus to the next item. +Not meaningful return value." + (when (and (slot-boundp obj 'table) (oref obj table)) + (with-slots (table) obj + (if (not (slot-boundp obj 'focus)) + (oset obj focus 0) + (oset obj focus (1+ (oref obj focus))) + ) + (if (<= (semanticdb-find-result-length table) (oref obj focus)) + (oset obj focus 0)) + ))) + +(defmethod semantic-displayor-focus-tag ((obj semantic-displayor-focus-abstract)) + "Return the next tag OBJ should focus on." + (when (and (slot-boundp obj 'table) (oref obj table)) + (with-slots (table) obj + (semanticdb-find-result-nth table (oref obj focus))))) + +(defmethod semantic-displayor-current-focus ((obj semantic-displayor-focus-abstract)) + "Return the tag currently in focus, or call parent method." + (if (and (slot-boundp obj 'focus) + (slot-boundp obj 'table) + ;; Only return the current focus IFF the minibuffer reflects + ;; the list this focus was derived from. + (slot-boundp obj 'last-prefix) + (string= (semantic-completion-text) (oref obj last-prefix)) + ) + ;; We need to focus + (if (oref obj find-file-focus) + (semanticdb-find-result-nth-in-buffer (oref obj table) (oref obj focus)) + ;; result-nth returns a cons with car being the tag, and cdr the + ;; database. + (car (semanticdb-find-result-nth (oref obj table) (oref obj focus)))) + ;; Do whatever + (call-next-method))) + +;;; Simple displayor which performs traditional display completion, +;; and also focuses with highlighting. +(defclass semantic-displayor-traditional-with-focus-highlight + (semantic-displayor-focus-abstract semantic-displayor-traditional) + ((find-file-focus :initform t)) + "Display completions in *Completions* buffer, with focus highlight. +A traditional displayor which can focus on a tag by showing it. +Same as `semantic-displayor-traditional', but with selection between +multiple tags with the same name done by 'focusing' on the source +location of the different tags to differentiate them.") + +(defmethod semantic-displayor-focus-request + ((obj semantic-displayor-traditional-with-focus-highlight)) + "Focus in on possible tag completions. +Focus is performed by cycling through the tags and highlighting +one in the source buffer." + (let* ((tablelength (semanticdb-find-result-length (oref obj table))) + (focus (semantic-displayor-focus-tag obj)) + ;; Raw tag info. + (rtag (car focus)) + (rtable (cdr focus)) + ;; Normalize + (nt (semanticdb-normalize-one-tag rtable rtag)) + (tag (cdr nt)) + (table (car nt)) + ) + ;; If we fail to normalize, resete. + (when (not tag) (setq table rtable tag rtag)) + ;; Do the focus. + (let ((buf (or (semantic-tag-buffer tag) + (and table (semanticdb-get-buffer table))))) + ;; If no buffer is provided, then we can make up a summary buffer. + (when (not buf) + (save-excursion + (set-buffer (get-buffer-create "*Completion Focus*")) + (erase-buffer) + (insert "Focus on tag: \n") + (insert (semantic-format-tag-summarize tag nil t) "\n\n") + (when table + (insert "From table: \n") + (insert (object-name table) "\n\n")) + (when buf + (insert "In buffer: \n\n") + (insert (format "%S" buf))) + (setq buf (current-buffer)))) + ;; Show the tag in the buffer. + (if (get-buffer-window buf) + (select-window (get-buffer-window buf)) + (switch-to-buffer-other-window buf t) + (select-window (get-buffer-window buf))) + ;; Now do some positioning + (unwind-protect + (if (semantic-tag-with-position-p tag) + ;; Full tag positional information available + (progn + (goto-char (semantic-tag-start tag)) + ;; This avoids a dangerous problem if we just loaded a tag + ;; from a file, but the original position was not updated + ;; in the TAG variable we are currently using. + (semantic-momentary-highlight-tag (semantic-current-tag)) + )) + (select-window (minibuffer-window))) + ;; Calculate text difference between contents and the focus item. + (let* ((mbc (semantic-completion-text)) + (ftn (semantic-tag-name tag)) + (diff (substring ftn (length mbc)))) + (semantic-completion-message + (format "%s [%d of %d matches]" diff (1+ (oref obj focus)) tablelength))) + ))) + + +;;; Tooltip completion lister +;; +;; Written and contributed by Masatake YAMATO <jet@gyve.org> +;; +;; Modified by Eric Ludlam for +;; * Safe compatibility for tooltip free systems. +;; * Don't use 'avoid package for tooltip positioning. + +(defclass semantic-displayor-tooltip (semantic-displayor-traditional) + ((max-tags :type integer + :initarg :max-tags + :initform 5 + :custom integer + :documentation + "Max number of tags displayed on tooltip at once. +If `force-show' is 1, this value is ignored with typing tab or space twice continuously. +if `force-show' is 0, this value is always ignored.") + (force-show :type integer + :initarg :force-show + :initform 1 + :custom (choice (const + :tag "Show when double typing" + 1) + (const + :tag "Show always" + 0) + (const + :tag "Show if the number of tags is less than `max-tags'." + -1)) + :documentation + "Control the behavior of the number of tags is greater than `max-tags'. +-1 means tags are never shown. +0 means the tags are always shown. +1 means tags are shown if space or tab is typed twice continuously.") + (typing-count :type integer + :initform 0 + :documentation + "Counter holding how many times the user types space or tab continuously before showing tags.") + (shown :type boolean + :initform nil + :documentation + "Flag representing whether tags is shown once or not.") + ) + "Display completions options in a tooltip. +Display mechanism using tooltip for a list of possible completions.") + +(defmethod initialize-instance :AFTER ((obj semantic-displayor-tooltip) &rest args) + "Make sure we have tooltips required." + (condition-case nil + (require 'tooltip) + (error nil)) + ) + +(defmethod semantic-displayor-show-request ((obj semantic-displayor-tooltip)) + "A request to show the current tags table." + (if (or (not (featurep 'tooltip)) (not tooltip-mode)) + ;; If we cannot use tooltips, then go to the normal mode with + ;; a traditional completion buffer. + (call-next-method) + (let* ((tablelong (semanticdb-strip-find-results (oref obj table))) + (table (semantic-unique-tag-table-by-name tablelong)) + (l (mapcar semantic-completion-displayor-format-tag-function table)) + (ll (length l)) + (typing-count (oref obj typing-count)) + (force-show (oref obj force-show)) + (matchtxt (semantic-completion-text)) + msg) + (if (or (oref obj shown) + (< ll (oref obj max-tags)) + (and (<= 0 force-show) + (< (1- force-show) typing-count))) + (progn + (oset obj typing-count 0) + (oset obj shown t) + (if (eq 1 ll) + ;; We Have only one possible match. There could be two cases. + ;; 1) input text != single match. + ;; --> Show it! + ;; 2) input text == single match. + ;; --> Complain about it, but still show the match. + (if (string= matchtxt (semantic-tag-name (car table))) + (setq msg (concat "[COMPLETE]\n" (car l))) + (setq msg (car l))) + ;; Create the long message. + (setq msg (mapconcat 'identity l "\n")) + ;; If there is nothing, say so! + (if (eq 0 (length msg)) + (setq msg "[NO MATCH]"))) + (semantic-displayor-tooltip-show msg)) + ;; The typing count determines if the user REALLY REALLY + ;; wanted to show that much stuff. Only increment + ;; if the current command is a completion command. + (if (and (stringp (this-command-keys)) + (string= (this-command-keys) "\C-i")) + (oset obj typing-count (1+ typing-count))) + ;; At this point, we know we have too many items. + ;; Lets be brave, and truncate l + (setcdr (nthcdr (oref obj max-tags) l) nil) + (setq msg (mapconcat 'identity l "\n")) + (cond + ((= force-show -1) + (semantic-displayor-tooltip-show (concat msg "\n..."))) + ((= force-show 1) + (semantic-displayor-tooltip-show (concat msg "\n(TAB for more)"))) + ))))) + +;;; Compatibility +;; +(eval-and-compile + (if (fboundp 'window-inside-edges) + ;; Emacs devel. + (defalias 'semantic-displayor-window-edges + 'window-inside-edges) + ;; Emacs 21 + (defalias 'semantic-displayor-window-edges + 'window-edges) + )) + +(defun semantic-displayor-point-position () + "Return the location of POINT as positioned on the selected frame. +Return a cons cell (X . Y)" + (let* ((frame (selected-frame)) + (left (frame-parameter frame 'left)) + (top (frame-parameter frame 'top)) + (point-pix-pos (posn-x-y (posn-at-point))) + (edges (window-inside-pixel-edges (selected-window)))) + (cons (+ (car point-pix-pos) (car edges) left) + (+ (cdr point-pix-pos) (cadr edges) top)))) + + +(defun semantic-displayor-tooltip-show (text) + "Display a tooltip with TEXT near cursor." + (let ((point-pix-pos (semantic-displayor-point-position)) + (tooltip-frame-parameters + (append tooltip-frame-parameters nil))) + (push + (cons 'left (+ (car point-pix-pos) (frame-char-width))) + tooltip-frame-parameters) + (push + (cons 'top (+ (cdr point-pix-pos) (frame-char-height))) + tooltip-frame-parameters) + (tooltip-show text))) + +(defmethod semantic-displayor-scroll-request ((obj semantic-displayor-tooltip)) + "A request to for the displayor to scroll the completion list (if needed)." + ;; Do scrolling in the tooltip. + (oset obj max-tags 30) + (semantic-displayor-show-request obj) + ) + +;; End code contributed by Masatake YAMATO <jet@gyve.org> + + +;;; Ghost Text displayor +;; +(defclass semantic-displayor-ghost (semantic-displayor-focus-abstract) + + ((ghostoverlay :type overlay + :documentation + "The overlay the ghost text is displayed in.") + (first-show :initform t + :documentation + "Non nil if we have not seen our first show request.") + ) + "Cycle completions inline with ghost text. +Completion displayor using ghost chars after point for focus options. +Whichever completion is currently in focus will be displayed as ghost +text using overlay options.") + +(defmethod semantic-displayor-next-action ((obj semantic-displayor-ghost)) + "The next action to take on the inline completion related to display." + (let ((ans (call-next-method)) + (table (when (slot-boundp obj 'table) + (oref obj table)))) + (if (and (eq ans 'displayend) + table + (= (semanticdb-find-result-length table) 1) + ) + nil + ans))) + +(defmethod semantic-displayor-cleanup ((obj semantic-displayor-ghost)) + "Clean up any mess this displayor may have." + (when (slot-boundp obj 'ghostoverlay) + (semantic-overlay-delete (oref obj ghostoverlay))) + ) + +(defmethod semantic-displayor-set-completions ((obj semantic-displayor-ghost) + table prefix) + "Set the list of tags to be completed over to TABLE." + (call-next-method) + + (semantic-displayor-cleanup obj) + ) + + +(defmethod semantic-displayor-show-request ((obj semantic-displayor-ghost)) + "A request to show the current tags table." +; (if (oref obj first-show) +; (progn +; (oset obj first-show nil) + (semantic-displayor-focus-next obj) + (semantic-displayor-focus-request obj) +; ) + ;; Only do the traditional thing if the first show request + ;; has been seen. Use the first one to start doing the ghost + ;; text display. +; (call-next-method) +; ) +) + +(defmethod semantic-displayor-focus-request + ((obj semantic-displayor-ghost)) + "Focus in on possible tag completions. +Focus is performed by cycling through the tags and showing a possible +completion text in ghost text." + (let* ((tablelength (semanticdb-find-result-length (oref obj table))) + (focus (semantic-displayor-focus-tag obj)) + (tag (car focus)) + ) + (if (not tag) + (semantic-completion-message "No tags to focus on.") + ;; Display the focus completion as ghost text after the current + ;; inline text. + (when (or (not (slot-boundp obj 'ghostoverlay)) + (not (semantic-overlay-live-p (oref obj ghostoverlay)))) + (oset obj ghostoverlay + (semantic-make-overlay (point) (1+ (point)) (current-buffer) t))) + + (let* ((lp (semantic-completion-text)) + (os (substring (semantic-tag-name tag) (length lp))) + (ol (oref obj ghostoverlay)) + ) + + (put-text-property 0 (length os) 'face 'region os) + + (semantic-overlay-put + ol 'display (concat os (buffer-substring (point) (1+ (point))))) + ) + ;; Calculate text difference between contents and the focus item. + (let* ((mbc (semantic-completion-text)) + (ftn (concat (semantic-tag-name tag))) + ) + (put-text-property (length mbc) (length ftn) 'face + 'bold ftn) + (semantic-completion-message + (format "%s [%d of %d matches]" ftn (1+ (oref obj focus)) tablelength))) + ))) + + +;;; ------------------------------------------------------------ +;;; Specific queries +;; +(defun semantic-complete-read-tag-buffer-deep (prompt &optional + default-tag + initial-input + history) + "Ask for a tag by name from the current buffer. +Available tags are from the current buffer, at any level. +Completion options are presented in a traditional way, with highlighting +to resolve same-name collisions. +PROMPT is a string to prompt with. +DEFAULT-TAG is a semantic tag or string to use as the default value. +If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. +HISTORY is a symbol representing a variable to store the history in." + (semantic-complete-read-tag-engine + (semantic-collector-buffer-deep prompt :buffer (current-buffer)) + (semantic-displayor-traditional-with-focus-highlight "simple") + ;;(semantic-displayor-tooltip "simple") + prompt + default-tag + initial-input + history) + ) + +(defun semantic-complete-read-tag-project (prompt &optional + default-tag + initial-input + history) + "Ask for a tag by name from the current project. +Available tags are from the current project, at the top level. +Completion options are presented in a traditional way, with highlighting +to resolve same-name collisions. +PROMPT is a string to prompt with. +DEFAULT-TAG is a semantic tag or string to use as the default value. +If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. +HISTORY is a symbol representing a variable to store the history in." + (semantic-complete-read-tag-engine + (semantic-collector-project-brutish prompt + :buffer (current-buffer) + :path (current-buffer) + ) + (semantic-displayor-traditional-with-focus-highlight "simple") + prompt + default-tag + initial-input + history) + ) + +(defun semantic-complete-inline-tag-project () + "Complete a symbol name by name from within the current project. +This is similar to `semantic-complete-read-tag-project', except +that the completion interaction is in the buffer where the context +was calculated from. +Customize `semantic-complete-inline-analyzer-displayor-class' +to control how completion options are displayed. +See `semantic-complete-inline-tag-engine' for details on how +completion works." + (let* ((collector (semantic-collector-project-brutish + "inline" + :buffer (current-buffer) + :path (current-buffer))) + (sbounds (semantic-ctxt-current-symbol-and-bounds)) + (syms (car sbounds)) + (start (car (nth 2 sbounds))) + (end (cdr (nth 2 sbounds))) + (rsym (reverse syms)) + (thissym (nth 1 sbounds)) + (nextsym (car-safe (cdr rsym))) + (complst nil)) + (when (and thissym (or (not (string= thissym "")) + nextsym)) + ;; Do a quick calcuation of completions. + (semantic-collector-calculate-completions + collector thissym nil) + ;; Get the master list + (setq complst (semanticdb-strip-find-results + (semantic-collector-all-completions collector thissym))) + ;; Shorten by name + (setq complst (semantic-unique-tag-table-by-name complst)) + (if (or (and (= (length complst) 1) + ;; Check to see if it is the same as what is there. + ;; if so, we can offer to complete. + (let ((compname (semantic-tag-name (car complst)))) + (not (string= compname thissym)))) + (> (length complst) 1)) + ;; There are several options. Do the completion. + (semantic-complete-inline-tag-engine + collector + (funcall semantic-complete-inline-analyzer-displayor-class + "inline displayor") + ;;(semantic-displayor-tooltip "simple") + (current-buffer) + start end)) + ))) + +(defun semantic-complete-read-tag-analyzer (prompt &optional + context + history) + "Ask for a tag by name based on the current context. +The function `semantic-analyze-current-context' is used to +calculate the context. `semantic-analyze-possible-completions' is used +to generate the list of possible completions. +PROMPT is the first part of the prompt. Additional prompt +is added based on the contexts full prefix. +CONTEXT is the semantic analyzer context to start with. +HISTORY is a symbol representing a variable to stor the history in. +usually a default-tag and initial-input are available for completion +prompts. these are calculated from the CONTEXT variable passed in." + (if (not context) (setq context (semantic-analyze-current-context (point)))) + (let* ((syms (semantic-ctxt-current-symbol (point))) + (inp (car (reverse syms)))) + (setq syms (nreverse (cdr (nreverse syms)))) + (semantic-complete-read-tag-engine + (semantic-collector-analyze-completions + prompt + :buffer (oref context buffer) + :context context) + (semantic-displayor-traditional-with-focus-highlight "simple") + (save-excursion + (set-buffer (oref context buffer)) + (goto-char (cdr (oref context bounds))) + (concat prompt (mapconcat 'identity syms ".") + (if syms "." "") + )) + nil + inp + history))) + +(defvar semantic-complete-inline-custom-type + (append '(radio) + (mapcar + (lambda (class) + (let* ((C (intern (car class))) + (doc (documentation-property C 'variable-documentation)) + (doc1 (car (split-string doc "\n"))) + ) + (list 'const + :tag doc1 + C))) + (eieio-build-class-alist semantic-displayor-abstract t)) + ) + "Possible options for inlince completion displayors. +Use this to enable custom editing.") + +(defcustom semantic-complete-inline-analyzer-displayor-class + 'semantic-displayor-traditional + "*Class for displayor to use with inline completion." + :group 'semantic + :type semantic-complete-inline-custom-type + ) + + +(defun semantic-complete-inline-analyzer (context) + "Complete a symbol name by name based on the current context. +This is similar to `semantic-complete-read-tag-analyze', except +that the completion interaction is in the buffer where the context +was calculated from. +CONTEXT is the semantic analyzer context to start with. +Customize `semantic-complete-inline-analyzer-displayor-class' +to control how completion options are displayed. + +See `semantic-complete-inline-tag-engine' for details on how +completion works." + (if (not context) (setq context (semantic-analyze-current-context (point)))) + (if (not context) (error "Nothing to complete on here")) + (let* ((collector (semantic-collector-analyze-completions + "inline" + :buffer (oref context buffer) + :context context)) + (syms (semantic-ctxt-current-symbol (point))) + (rsym (reverse syms)) + (thissym (car rsym)) + (nextsym (car-safe (cdr rsym))) + (complst nil)) + (when (and thissym (or (not (string= thissym "")) + nextsym)) + ;; Do a quick calcuation of completions. + (semantic-collector-calculate-completions + collector thissym nil) + ;; Get the master list + (setq complst (semanticdb-strip-find-results + (semantic-collector-all-completions collector thissym))) + ;; Shorten by name + (setq complst (semantic-unique-tag-table-by-name complst)) + (if (or (and (= (length complst) 1) + ;; Check to see if it is the same as what is there. + ;; if so, we can offer to complete. + (let ((compname (semantic-tag-name (car complst)))) + (not (string= compname thissym)))) + (> (length complst) 1)) + ;; There are several options. Do the completion. + (semantic-complete-inline-tag-engine + collector + (funcall semantic-complete-inline-analyzer-displayor-class + "inline displayor") + ;;(semantic-displayor-tooltip "simple") + (oref context buffer) + (car (oref context bounds)) + (cdr (oref context bounds)) + )) + ))) + +(defcustom semantic-complete-inline-analyzer-idle-displayor-class + 'semantic-displayor-ghost + "*Class for displayor to use with inline completion at idle time." + :group 'semantic + :type semantic-complete-inline-custom-type + ) + +(defun semantic-complete-inline-analyzer-idle (context) + "Complete a symbol name by name based on the current context for idle time. +CONTEXT is the semantic analyzer context to start with. +This function is used from `semantic-idle-completions-mode'. + +This is the same as `semantic-complete-inline-analyzer', except that +it uses `semantic-complete-inline-analyzer-idle-displayor-class' +to control how completions are displayed. + +See `semantic-complete-inline-tag-engine' for details on how +completion works." + (let ((semantic-complete-inline-analyzer-displayor-class + semantic-complete-inline-analyzer-idle-displayor-class)) + (semantic-complete-inline-analyzer context) + )) + + +;;; ------------------------------------------------------------ +;;; Testing/Samples +;; +(defun semantic-complete-test () + "Test completion mechanisms." + (interactive) + (message "%S" + (semantic-format-tag-prototype + (semantic-complete-read-tag-project "Symbol: ") + ))) + +(defun semantic-complete-jump-local () + "Jump to a semantic symbol." + (interactive) + (let ((tag (semantic-complete-read-tag-buffer-deep "Symbol: "))) + (when (semantic-tag-p tag) + (push-mark) + (goto-char (semantic-tag-start tag)) + (semantic-momentary-highlight-tag tag) + (message "%S: %s " + (semantic-tag-class tag) + (semantic-tag-name tag))))) + +(defun semantic-complete-jump () + "Jump to a semantic symbol." + (interactive) + (let* ((tag (semantic-complete-read-tag-project "Symbol: "))) + (when (semantic-tag-p tag) + (push-mark) + (semantic-go-to-tag tag) + (switch-to-buffer (current-buffer)) + (semantic-momentary-highlight-tag tag) + (message "%S: %s " + (semantic-tag-class tag) + (semantic-tag-name tag))))) + +(defun semantic-complete-analyze-and-replace () + "Perform prompt completion to do in buffer completion. +`semantic-analyze-possible-completions' is used to determine the +possible values. +The minibuffer is used to perform the completion. +The result is inserted as a replacement of the text that was there." + (interactive) + (let* ((c (semantic-analyze-current-context (point))) + (tag (save-excursion (semantic-complete-read-tag-analyzer "" c)))) + ;; Take tag, and replace context bound with its name. + (goto-char (car (oref c bounds))) + (delete-region (point) (cdr (oref c bounds))) + (insert (semantic-tag-name tag)) + (message "%S" (semantic-format-tag-summarize tag)))) + +(defun semantic-complete-analyze-inline () + "Perform prompt completion to do in buffer completion. +`semantic-analyze-possible-completions' is used to determine the +possible values. +The function returns immediately, leaving the buffer in a mode that +will perform the completion. +Configure `semantic-complete-inline-analyzer-displayor-class' to change +how completion options are displayed." + (interactive) + ;; Only do this if we are not already completing something. + (if (not (semantic-completion-inline-active-p)) + (semantic-complete-inline-analyzer + (semantic-analyze-current-context (point)))) + ;; Report a message if things didn't startup. + (if (and (interactive-p) + (not (semantic-completion-inline-active-p))) + (message "Inline completion not needed.") + ;; Since this is most likely bound to something, and not used + ;; at idle time, throw in a TAB for good measure. + (semantic-complete-inline-TAB) + )) + +(defun semantic-complete-analyze-inline-idle () + "Perform prompt completion to do in buffer completion. +`semantic-analyze-possible-completions' is used to determine the +possible values. +The function returns immediately, leaving the buffer in a mode that +will perform the completion. +Configure `semantic-complete-inline-analyzer-idle-displayor-class' +to change how completion options are displayed." + (interactive) + ;; Only do this if we are not already completing something. + (if (not (semantic-completion-inline-active-p)) + (semantic-complete-inline-analyzer-idle + (semantic-analyze-current-context (point)))) + ;; Report a message if things didn't startup. + (if (and (interactive-p) + (not (semantic-completion-inline-active-p))) + (message "Inline completion not needed.")) + ) + +(defun semantic-complete-self-insert (arg) + "Like `self-insert-command', but does completion afterwards. +ARG is passed to `self-insert-command'. If ARG is nil, +use `semantic-complete-analyze-inline' to complete." + (interactive "p") + ;; If we are already in a completion scenario, exit now, and then start over. + (semantic-complete-inline-exit) + + ;; Insert the key + (self-insert-command arg) + + ;; Prepare for doing completion, but exit quickly if there is keyboard + ;; input. + (when (and (not (semantic-exit-on-input 'csi + (semantic-fetch-tags) + (semantic-throw-on-input 'csi) + nil)) + (= arg 1) + (not (semantic-exit-on-input 'csi + (semantic-analyze-current-context) + (semantic-throw-on-input 'csi) + nil))) + (condition-case nil + (semantic-complete-analyze-inline) + ;; Ignore errors. Seems likely that we'll get some once in a while. + (error nil)) + )) + +;; @TODO - I can't find where this fcn is used. Delete? + +;;;;###autoload +;(defun semantic-complete-inline-project () +; "Perform inline completion for any symbol in the current project. +;`semantic-analyze-possible-completions' is used to determine the +;possible values. +;The function returns immediately, leaving the buffer in a mode that +;will perform the completion." +; (interactive) +; ;; Only do this if we are not already completing something. +; (if (not (semantic-completion-inline-active-p)) +; (semantic-complete-inline-tag-project)) +; ;; Report a message if things didn't startup. +; (if (and (interactive-p) +; (not (semantic-completion-inline-active-p))) +; (message "Inline completion not needed.")) +; ) + +;; End +(provide 'semantic/complete) + +;;; semantic-complete.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/edit.el Sat Aug 29 19:00:35 2009 +0000 @@ -0,0 +1,965 @@ +;;; semantic-edit.el --- Edit Management for Semantic + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;;; 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; In Semantic 1.x, changes were handled in a simplistic manner, where +;; tags that changed were reparsed one at a time. Any other form of +;; edit were managed through a full reparse. +;; +;; This code attempts to minimize the number of times a full reparse +;; needs to occur. While overlays and tags will continue to be +;; recycled in the simple case, new cases where tags are inserted +;; or old tags removed from the original list are handled. +;; + +;;; NOTES FOR IMPROVEMENT +;; +;; Work done by the incremental parser could be improved by the +;; following: +;; +;; 1. Tags created could have as a property an overlay marking a region +;; of themselves that can be edited w/out affecting the definition of +;; that tag. +;; +;; 2. Tags w/ positioned children could have a property of an +;; overlay marking the region in themselves that contain the +;; children. This could be used to better improve splicing near +;; the beginning and end of the child lists. +;; + +;;; BUGS IN INCREMENTAL PARSER +;; +;; 1. Changes in the whitespace between tags could extend a +;; following tag. These will be marked as merely unmatched +;; syntax instead. +;; +;; 2. Incremental parsing while a new function is being typed in +;; somtimes gets a chance only when lists are incomplete, +;; preventing correct context identification. + +;; +(require 'semantic) +;; (require 'working) + +;;; Code: +(defvar semantic-after-partial-cache-change-hook nil + "Hooks run after the buffer cache has been updated. + +This hook will run when the cache has been partially reparsed. +Partial reparses are incurred when a user edits a buffer, and only the +modified sections are rescanned. + +Hook functions must take one argument, which is the list of tags +updated in the current buffer. + +For language specific hooks, make sure you define this as a local hook.") + +(defvar semantic-change-hooks nil + "Hooks run when semantic detects a change in a buffer. +Each hook function must take three arguments, identical to the +common hook `after-change-functions'.") + +(defvar semantic-reparse-needed-change-hook nil + "Hooks run when a user edit is detected as needing a reparse. +For language specific hooks, make sure you define this as a local +hook. +Not used yet; part of the next generation reparse mechanism") + +(defvar semantic-no-reparse-needed-change-hook nil + "Hooks run when a user edit is detected as not needing a reparse. +If the hook returns non-nil, then declare that a reparse is needed. +For language specific hooks, make sure you define this as a local +hook. +Not used yet; part of the next generation reparse mechanism.") + +(defvar semantic-edits-new-change-hooks nil + "Hooks run when a new change is found. +Functions must take one argument representing an overlay on that change.") + +(defvar semantic-edits-delete-change-hooks nil + "Hooks run before a change overlay is deleted. +Deleted changes occur when multiple changes are merged. +Functions must take one argument representing an overlay being deleted.") + +(defvar semantic-edits-move-change-hooks nil + "Hooks run after a change overlay is moved. +Changes move when a new change overlaps an old change. The old change +will be moved. +Functions must take one argument representing an overlay being moved.") + +(defvar semantic-edits-reparse-change-hooks nil + "Hooks run after a change results in a reparse. +Functions are called before the overlay is deleted, and after the +incremental reparse.") + +(defvar semantic-edits-incremental-reparse-failed-hooks nil + "Hooks run after the incremental parser fails. +When this happens, the buffer is marked as needing a full reprase.") + +(defcustom semantic-edits-verbose-flag nil + "Non-nil means the incremental perser is verbose. +If nil, errors are still displayed, but informative messages are not." + :group 'semantic + :type 'boolean) + +;;; Change State management +;; +;; Manage a series of overlays that define changes recently +;; made to the current buffer. +(defun semantic-change-function (start end length) + "Provide a mechanism for semantic tag management. +Argument START, END, and LENGTH specify the bounds of the change." + (setq semantic-unmatched-syntax-cache-check t) + (let ((inhibit-point-motion-hooks t) + ) + (run-hook-with-args 'semantic-change-hooks start end length) + )) + +(defun semantic-changes-in-region (start end &optional buffer) + "Find change overlays which exist in whole or in part between START and END. +Optional argument BUFFER is the buffer to search for changes in." + (save-excursion + (if buffer (set-buffer buffer)) + (let ((ol (semantic-overlays-in (max start (point-min)) + (min end (point-max)))) + (ret nil)) + (while ol + (when (semantic-overlay-get (car ol) 'semantic-change) + (setq ret (cons (car ol) ret))) + (setq ol (cdr ol))) + (sort ret #'(lambda (a b) (< (semantic-overlay-start a) + (semantic-overlay-start b))))))) + +(defun semantic-edits-change-function-handle-changes (start end length) + "Run whenever a buffer controlled by `semantic-mode' change. +Tracks when and how the buffer is re-parsed. +Argument START, END, and LENGTH specify the bounds of the change." + ;; We move start/end by one so that we can merge changes that occur + ;; just before, or just after. This lets simple typing capture everything + ;; into one overlay. + (let ((changes-in-change (semantic-changes-in-region (1- start) (1+ end))) + ) + (semantic-parse-tree-set-needs-update) + (if (not changes-in-change) + (let ((o (semantic-make-overlay start end))) + (semantic-overlay-put o 'semantic-change t) + ;; Run the hooks safely. When hooks blow it, our dirty + ;; function will be removed from the list of active change + ;; functions. + (condition-case nil + (run-hook-with-args 'semantic-edits-new-change-hooks o) + (error nil))) + (let ((tmp changes-in-change)) + ;; Find greatest bounds of all changes + (while tmp + (when (< (semantic-overlay-start (car tmp)) start) + (setq start (semantic-overlay-start (car tmp)))) + (when (> (semantic-overlay-end (car tmp)) end) + (setq end (semantic-overlay-end (car tmp)))) + (setq tmp (cdr tmp))) + ;; Move the first found overlay, recycling that overlay. + (semantic-overlay-move (car changes-in-change) start end) + (condition-case nil + (run-hook-with-args 'semantic-edits-move-change-hooks + (car changes-in-change)) + (error nil)) + (setq changes-in-change (cdr changes-in-change)) + ;; Delete other changes. They are now all bound here. + (while changes-in-change + (condition-case nil + (run-hook-with-args 'semantic-edits-delete-change-hooks + (car changes-in-change)) + (error nil)) + (semantic-overlay-delete (car changes-in-change)) + (setq changes-in-change (cdr changes-in-change)))) + ))) + +(defsubst semantic-edits-flush-change (change) + "Flush the CHANGE overlay." + (condition-case nil + (run-hook-with-args 'semantic-edits-delete-change-hooks + change) + (error nil)) + (semantic-overlay-delete change)) + +(defun semantic-edits-flush-changes () + "Flush the changes in the current buffer." + (let ((changes (semantic-changes-in-region (point-min) (point-max)))) + (while changes + (semantic-edits-flush-change (car changes)) + (setq changes (cdr changes)))) + ) + +(defun semantic-edits-change-in-one-tag-p (change hits) + "Return non-nil of the overlay CHANGE exists solely in one leaf tag. +HITS is the list of tags that CHANGE is in. It can have more than +one tag in it if the leaf tag is within a parent tag." + (and (< (semantic-tag-start (car hits)) + (semantic-overlay-start change)) + (> (semantic-tag-end (car hits)) + (semantic-overlay-end change)) + ;; Recurse on the rest. If this change is inside all + ;; of these tags, then they are all leaves or parents + ;; of the smallest tag. + (or (not (cdr hits)) + (semantic-edits-change-in-one-tag-p change (cdr hits)))) + ) + +;;; Change/Tag Query functions +;; +;; A change (region of space) can effect tags in different ways. +;; These functions perform queries on a buffer to determine different +;; ways that a change effects a buffer. +;; +;; NOTE: After debugging these, replace below to no longer look +;; at point and mark (via comments I assume.) +(defsubst semantic-edits-os (change) + "For testing: Start of CHANGE, or smaller of (point) and (mark)." + (if change (semantic-overlay-start change) + (if (< (point) (mark)) (point) (mark)))) + +(defsubst semantic-edits-oe (change) + "For testing: End of CHANGE, or larger of (point) and (mark)." + (if change (semantic-overlay-end change) + (if (> (point) (mark)) (point) (mark)))) + +(defun semantic-edits-change-leaf-tag (change) + "A leaf tag which completely encompasses CHANGE. +If change overlaps a tag, but is not encompassed in it, return nil. +Use `semantic-edits-change-overlap-leaf-tag'. +If CHANGE is completely encompassed in a tag, but overlaps sub-tags, +return nil." + (let* ((start (semantic-edits-os change)) + (end (semantic-edits-oe change)) + (tags (nreverse + (semantic-find-tag-by-overlay-in-region + start end)))) + ;; A leaf is always first in this list + (if (and tags + (<= (semantic-tag-start (car tags)) start) + (> (semantic-tag-end (car tags)) end)) + ;; Ok, we have a match. If this tag has children, + ;; we have to do more tests. + (let ((chil (semantic-tag-components (car tags)))) + (if (not chil) + ;; Simple leaf. + (car tags) + ;; For this type, we say that we encompass it if the + ;; change occurs outside the range of the children. + (if (or (not (semantic-tag-with-position-p (car chil))) + (> start (semantic-tag-end (nth (1- (length chil)) chil))) + (< end (semantic-tag-start (car chil)))) + ;; We have modifications to the definition of this parent + ;; so we have to reparse the whole thing. + (car tags) + ;; We actually modified an area between some children. + ;; This means we should return nil, as that case is + ;; calculated by someone else. + nil))) + nil))) + +(defun semantic-edits-change-between-tags (change) + "Return a cache list of tags surrounding CHANGE. +The returned list is the CONS cell in the master list pointing to +a tag just before CHANGE. The CDR will have the tag just after CHANGE. +CHANGE cannot encompass or overlap a leaf tag. +If CHANGE is fully encompassed in a tag that has children, and +this change occurs between those children, this returns non-nil. +See `semantic-edits-change-leaf-tag' for details on parents." + (let* ((start (semantic-edits-os change)) + (end (semantic-edits-oe change)) + (tags (nreverse + (semantic-find-tag-by-overlay-in-region + start end))) + (list-to-search nil) + (found nil)) + (if (not tags) + (setq list-to-search semantic--buffer-cache) + ;; A leaf is always first in this list + (if (and (< (semantic-tag-start (car tags)) start) + (> (semantic-tag-end (car tags)) end)) + ;; We are completely encompassed in a tag. + (if (setq list-to-search + (semantic-tag-components (car tags))) + ;; Ok, we are completely encompassed within the first tag + ;; entry, AND that tag has children. This means that change + ;; occured outside of all children, but inside some tag + ;; with children. + (if (or (not (semantic-tag-with-position-p (car list-to-search))) + (> start (semantic-tag-end + (nth (1- (length list-to-search)) + list-to-search))) + (< end (semantic-tag-start (car list-to-search)))) + ;; We have modifications to the definition of this parent + ;; and not between it's children. Clear the search list. + (setq list-to-search nil))) + ;; Search list is nil. + )) + ;; If we have a search list, lets go. Otherwise nothing. + (while (and list-to-search (not found)) + (if (cdr list-to-search) + ;; We end when the start of the CDR is after the end of our + ;; asked change. + (if (< (semantic-tag-start (cadr list-to-search)) end) + (setq list-to-search (cdr list-to-search)) + (setq found t)) + (setq list-to-search nil))) + ;; Return it. If it is nil, there is a logic bug, and we need + ;; to avoid this bit of logic anyway. + list-to-search + )) + +(defun semantic-edits-change-over-tags (change) + "Return a cache list of tags surrounding a CHANGE encompassing tags. +CHANGE must not only include all overlapped tags (excepting possible +parent tags) in their entirety. In this case, the change may be deleting +or moving whole tags. +The return value is a vector. +Cell 0 is a list of all tags completely encompassed in change. +Cell 1 is the cons cell into a master parser cache starting with +the cell which occurs BEFORE the first position of CHANGE. +Cell 2 is the parent of cell 1, or nil for the buffer cache. +This function returns nil if any tag covered by change is not +completely encompassed. +See `semantic-edits-change-leaf-tag' for details on parents." + (let* ((start (semantic-edits-os change)) + (end (semantic-edits-oe change)) + (tags (nreverse + (semantic-find-tag-by-overlay-in-region + start end))) + (parent nil) + (overlapped-tags nil) + inner-start inner-end + (list-to-search nil)) + ;; By the time this is already called, we know that it is + ;; not a leaf change, nor a between tag change. That leaves + ;; an overlap, and this condition. + + ;; A leaf is always first in this list. + ;; Is the leaf encompassed in this change? + (if (and tags + (>= (semantic-tag-start (car tags)) start) + (<= (semantic-tag-end (car tags)) end)) + (progn + ;; We encompass one whole change. + (setq overlapped-tags (list (car tags)) + inner-start (semantic-tag-start (car tags)) + inner-end (semantic-tag-end (car tags)) + tags (cdr tags)) + ;; Keep looping while tags are inside the change. + (while (and tags + (>= (semantic-tag-start (car tags)) start) + (<= (semantic-tag-end (car tags)) end)) + + ;; Check if this new all-encompassing tag is a parent + ;; of that which went before. Only check end because + ;; we know that start is less than inner-start since + ;; tags was sorted on that. + (if (> (semantic-tag-end (car tags)) inner-end) + ;; This is a parent. Drop the children found + ;; so far. + (setq overlapped-tags (list (car tags)) + inner-start (semantic-tag-start (car tags)) + inner-end (semantic-tag-end (car tags)) + ) + ;; It is not a parent encompassing tag + (setq overlapped-tags (cons (car tags) + overlapped-tags) + inner-start (semantic-tag-start (car tags)))) + (setq tags (cdr tags))) + (if (not tags) + ;; There are no tags left, and all tags originally + ;; found are encompassed by the change. Setup our list + ;; from the cache + (setq list-to-search semantic--buffer-cache);; We have a tag ouside the list. Check for + ;; We know we have a parent because it would + ;; completely cover the change. A tag can only + ;; do that if it is a parent after we get here. + (when (and tags + (< (semantic-tag-start (car tags)) start) + (> (semantic-tag-end (car tags)) end)) + ;; We have a parent. Stuff in the search list. + (setq parent (car tags) + list-to-search (semantic-tag-components parent)) + ;; If the first of TAGS is a parent (see above) + ;; then clear out the list. All other tags in + ;; here must therefore be parents of the car. + (setq tags nil) + ;; One last check, If start is before the first + ;; tag or after the last, we may have overlap into + ;; the characters that make up the definition of + ;; the tag we are parsing. + (when (or (semantic-tag-with-position-p (car list-to-search)) + (< start (semantic-tag-start + (car list-to-search))) + (> end (semantic-tag-end + (nth (1- (length list-to-search)) + list-to-search)))) + ;; We have a problem + (setq list-to-search nil + parent nil)))) + + (when list-to-search + + ;; Ok, return the vector only if all TAGS are + ;; confirmed as the lineage of `overlapped-tags' + ;; which must have a value by now. + + ;; Loop over the search list to find the preceeding CDR. + ;; Fortunatly, (car overlapped-tags) happens to be + ;; the first tag positionally. + (let ((tokstart (semantic-tag-start (car overlapped-tags)))) + (while (and list-to-search + ;; Assume always (car (cdr list-to-search)). + ;; A thrown error will be captured nicely, but + ;; that case shouldn't happen. + + ;; We end when the start of the CDR is after the + ;; end of our asked change. + (cdr list-to-search) + (< (semantic-tag-start (car (cdr list-to-search))) + tokstart) + (setq list-to-search (cdr list-to-search))))) + ;; Create the return vector + (vector overlapped-tags + list-to-search + parent) + )) + nil))) + +;;; Default Incremental Parser +;; +;; Logic about how to group changes for effective reparsing and splicing. + +(defun semantic-parse-changes-failed (&rest args) + "Signal that Semantic failed to parse changes. +That is, display a message by passing all ARGS to `format', then throw +a 'semantic-parse-changes-failed exception with value t." + (when semantic-edits-verbose-flag + (message "Semantic parse changes failed: %S" + (apply 'format args))) + (throw 'semantic-parse-changes-failed t)) + +(defsubst semantic-edits-incremental-fail () + "When the incremental parser fails, we mark that we need a full reparse." + ;;(debug) + (semantic-parse-tree-set-needs-rebuild) + (when semantic-edits-verbose-flag + (message "Force full reparse (%s)" + (buffer-name (current-buffer)))) + (run-hooks 'semantic-edits-incremental-reparse-failed-hooks)) + +(defun semantic-edits-incremental-parser () + "Incrementally reparse the current buffer. +Incremental parser allows semantic to only reparse those sections of +the buffer that have changed. This function depends on +`semantic-edits-change-function-handle-changes' setting up change +overlays in the current buffer. Those overlays are analyzed against +the semantic cache to see what needs to be changed." + (let ((changed-tags + ;; Don't use `semantic-safe' here to explicitly catch errors + ;; and reset the parse tree. + (catch 'semantic-parse-changes-failed + (if debug-on-error + (semantic-edits-incremental-parser-1) + (condition-case err + (semantic-edits-incremental-parser-1) + (error + (message "incremental parser error: %S" + (error-message-string err)) + t)))))) + (when (eq changed-tags t) + ;; Force a full reparse. + (semantic-edits-incremental-fail) + (setq changed-tags nil)) + changed-tags)) + +(defmacro semantic-edits-assert-valid-region () + "Asert that parse-start and parse-end are sorted correctly." +;;; (if (> parse-start parse-end) +;;; (error "Bug is %s !> %d! Buff min/max = [ %d %d ]" +;;; parse-start parse-end +;;; (point-min) (point-max))) + ) + +(defun semantic-edits-incremental-parser-1 () + "Incrementally reparse the current buffer. +Return the list of tags that changed. +If the incremental parse fails, throw a 'semantic-parse-changes-failed +exception with value t, that can be caught to schedule a full reparse. +This function is for internal use by `semantic-edits-incremental-parser'." + (let* ((changed-tags nil) + (debug-on-quit t) ; try to find this annoying bug! + (changes (semantic-changes-in-region + (point-min) (point-max))) + (tags nil) ;tags found at changes + (newf-tags nil) ;newfound tags in change + (parse-start nil) ;location to start parsing + (parse-end nil) ;location to end parsing + (parent-tag nil) ;parent of the cache list. + (cache-list nil) ;list of children within which + ;we incrementally reparse. + (reparse-symbol nil) ;The ruled we start at for reparse. + (change-group nil) ;changes grouped in this reparse + (last-cond nil) ;track the last case used. + ;query this when debugging to find + ;source of bugs. + ) + (or changes + ;; If we were called, and there are no changes, then we + ;; don't know what to do. Force a full reparse. + (semantic-parse-changes-failed "Don't know what to do")) + ;; Else, we have some changes. Loop over them attempting to + ;; patch things up. + (while changes + ;; Calculate the reparse boundary. + ;; We want to take some set of changes, and group them + ;; together into a small change group. One change forces + ;; a reparse of a larger region (the size of some set of + ;; tags it encompases.) It may contain several tags. + ;; That region may have other changes in it (several small + ;; changes in one function, for example.) + ;; Optimize for the simple cases here, but try to handle + ;; complex ones too. + + (while (and changes ; we still have changes + (or (not parse-start) + ;; Below, if the change we are looking at + ;; is not the first change for this + ;; iteration, and it starts before the end + ;; of current parse region, then it is + ;; encompased within the bounds of tags + ;; modified by the previous iteration's + ;; change. + (< (semantic-overlay-start (car changes)) + parse-end))) + + ;; REMOVE LATER + (if (eq (car changes) (car change-group)) + (semantic-parse-changes-failed + "Possible infinite loop detected")) + + ;; Store this change in this change group. + (setq change-group (cons (car changes) change-group)) + + (cond + ;; Is this is a new parse group? + ((not parse-start) + (setq last-cond "new group") + (let (tmp) + (cond + +;;;; Are we encompassed all in one tag? + ((setq tmp (semantic-edits-change-leaf-tag (car changes))) + (setq last-cond "Encompassed in tag") + (setq tags (list tmp) + parse-start (semantic-tag-start tmp) + parse-end (semantic-tag-end tmp) + ) + (semantic-edits-assert-valid-region)) + +;;;; Did the change occur between some tags? + ((setq cache-list (semantic-edits-change-between-tags + (car changes))) + (setq last-cond "Between and not overlapping tags") + ;; The CAR of cache-list is the tag just before + ;; our change, but wasn't modified. Hmmm. + ;; Bound our reparse between these two tags + (setq tags nil + parent-tag + (car (semantic-find-tag-by-overlay + parse-start))) + (cond + ;; A change at the beginning of the buffer. + ;; Feb 06 - + ;; IDed when the first cache-list tag is after + ;; our change, meaning there is nothing before + ;; the chnge. + ((> (semantic-tag-start (car cache-list)) + (semantic-overlay-end (car changes))) + (setq last-cond "Beginning of buffer") + (setq parse-start + ;; Don't worry about parents since + ;; there there would be an exact + ;; match in the tag list otherwise + ;; and the routine would fail. + (point-min) + parse-end + (semantic-tag-start (car cache-list))) + (semantic-edits-assert-valid-region) + ) + ;; A change stuck on the first surrounding tag. + ((= (semantic-tag-end (car cache-list)) + (semantic-overlay-start (car changes))) + (setq last-cond "Beginning of Tag") + ;; Reparse that first tag. + (setq parse-start + (semantic-tag-start (car cache-list)) + parse-end + (semantic-overlay-end (car changes)) + tags + (list (car cache-list))) + (semantic-edits-assert-valid-region) + ) + ;; A change at the end of the buffer. + ((not (car (cdr cache-list))) + (setq last-cond "End of buffer") + (setq parse-start (semantic-tag-end + (car cache-list)) + parse-end (point-max)) + (semantic-edits-assert-valid-region) + ) + (t + (setq last-cond "Default") + (setq parse-start + (semantic-tag-end (car cache-list)) + parse-end + (semantic-tag-start (car (cdr cache-list))) + ) + (semantic-edits-assert-valid-region)))) + +;;;; Did the change completely overlap some number of tags? + ((setq tmp (semantic-edits-change-over-tags + (car changes))) + (setq last-cond "Overlap multiple tags") + ;; Extract the information + (setq tags (aref tmp 0) + cache-list (aref tmp 1) + parent-tag (aref tmp 2)) + ;; We can calculate parse begin/end by checking + ;; out what is in TAGS. The one near start is + ;; always first. Make sure the reprase includes + ;; the `whitespace' around the snarfed tags. + ;; Since cache-list is positioned properly, use it + ;; to find that boundary. + (if (eq (car tags) (car cache-list)) + ;; Beginning of the buffer! + (let ((end-marker (nth (length tags) + cache-list))) + (setq parse-start (point-min)) + (if end-marker + (setq parse-end + (semantic-tag-start end-marker)) + (setq parse-end (semantic-overlay-end + (car changes)))) + (semantic-edits-assert-valid-region) + ) + ;; Middle of the buffer. + (setq parse-start + (semantic-tag-end (car cache-list))) + ;; For the end, we need to scoot down some + ;; number of tags. We 1+ the length of tags + ;; because we want to skip the first tag + ;; (remove 1-) then want the tag after the end + ;; of the list (1+) + (let ((end-marker (nth (1+ (length tags)) cache-list))) + (if end-marker + (setq parse-end (semantic-tag-start end-marker)) + ;; No marker. It is the last tag in our + ;; list of tags. Only possible if END + ;; already matches the end of that tag. + (setq parse-end + (semantic-overlay-end (car changes))))) + (semantic-edits-assert-valid-region) + )) + +;;;; Unhandled case. + ;; Throw error, and force full reparse. + ((semantic-parse-changes-failed "Unhandled change group"))) + )) + ;; Is this change inside the previous parse group? + ;; We already checked start. + ((< (semantic-overlay-end (car changes)) parse-end) + (setq last-cond "in bounds") + nil) + ;; This change extends the current parse group. + ;; Find any new tags, and see how to append them. + ((semantic-parse-changes-failed + (setq last-cond "overlap boundary") + "Unhandled secondary change overlapping boundary")) + ) + ;; Prepare for the next iteration. + (setq changes (cdr changes))) + + ;; By the time we get here, all TAGS are children of + ;; some parent. They should all have the same start symbol + ;; since that is how the multi-tag parser works. Grab + ;; the reparse symbol from the first of the returned tags. + ;; + ;; Feb '06 - If repase-symbol is nil, then they are top level + ;; tags. (I'm guessing.) Is this right? + (setq reparse-symbol + (semantic--tag-get-property (car (or tags cache-list)) + 'reparse-symbol)) + ;; Find a parent if not provided. + (and (not parent-tag) tags + (setq parent-tag + (semantic-find-tag-parent-by-overlay + (car tags)))) + ;; We can do the same trick for our parent and resulting + ;; cache list. + (unless cache-list + (if parent-tag + (setq cache-list + ;; We need to get all children in case we happen + ;; to have a mix of positioned and non-positioned + ;; children. + (semantic-tag-components parent-tag)) + ;; Else, all the tags since there is no parent. + ;; It sucks to have to use the full buffer cache in + ;; this case because it can be big. Failure to provide + ;; however results in a crash. + (setq cache-list semantic--buffer-cache) + )) + ;; Use the boundary to calculate the new tags found. + (setq newf-tags (semantic-parse-region + parse-start parse-end reparse-symbol)) + ;; Make sure all these tags are given overlays. + ;; They have already been cooked by the parser and just + ;; need the overlays. + (let ((tmp newf-tags)) + (while tmp + (semantic--tag-link-to-buffer (car tmp)) + (setq tmp (cdr tmp)))) + + ;; See how this change lays out. + (cond + +;;;; Whitespace change + ((and (not tags) (not newf-tags)) + ;; A change that occured outside of any existing tags + ;; and there are no new tags to replace it. + (when semantic-edits-verbose-flag + (message "White space changes")) + nil + ) + +;;;; New tags in old whitespace area. + ((and (not tags) newf-tags) + ;; A change occured outside existing tags which added + ;; a new tag. We need to splice these tags back + ;; into the cache at the right place. + (semantic-edits-splice-insert newf-tags parent-tag cache-list) + + (setq changed-tags + (append newf-tags changed-tags)) + + (when semantic-edits-verbose-flag + (message "Inserted tags: (%s)" + (semantic-format-tag-name (car newf-tags)))) + ) + +;;;; Old tags removed + ((and tags (not newf-tags)) + ;; A change occured where pre-existing tags were + ;; deleted! Remove the tag from the cache. + (semantic-edits-splice-remove tags parent-tag cache-list) + + (setq changed-tags + (append tags changed-tags)) + + (when semantic-edits-verbose-flag + (message "Deleted tags: (%s)" + (semantic-format-tag-name (car tags)))) + ) + +;;;; One tag was updated. + ((and (= (length tags) 1) (= (length newf-tags) 1)) + ;; One old tag was modified, and it is replaced by + ;; One newfound tag. Splice the new tag into the + ;; position of the old tag. + ;; Do the splice. + (semantic-edits-splice-replace (car tags) (car newf-tags)) + ;; Add this tag to our list of changed toksns + (setq changed-tags (cons (car tags) changed-tags)) + ;; Debug + (when semantic-edits-verbose-flag + (message "Update Tag Table: %s" + (semantic-format-tag-name (car tags) nil t))) + ;; Flush change regardless of above if statement. + ) + +;;;; Some unhandled case. + ((semantic-parse-changes-failed "Don't know what to do"))) + + ;; We got this far, and we didn't flag a full reparse. + ;; Clear out this change group. + (while change-group + (semantic-edits-flush-change (car change-group)) + (setq change-group (cdr change-group))) + + ;; Don't increment change here because an earlier loop + ;; created change-groups. + (setq parse-start nil) + ) + ;; Mark that we are done with this glop + (semantic-parse-tree-set-up-to-date) + ;; Return the list of tags that changed. The caller will + ;; use this information to call hooks which can fix themselves. + changed-tags)) + +;; Make it the default changes parser +(defalias 'semantic-parse-changes-default + 'semantic-edits-incremental-parser) + +;;; Cache Splicing +;; +;; The incremental parser depends on the ability to parse up sections +;; of the file, and splice the results back into the cache. There are +;; three types of splices. A REPLACE, an ADD, and a REMOVE. REPLACE +;; is one of the simpler cases, as the starting cons cell representing +;; the old tag can be used to auto-splice in. ADD and REMOVE +;; require scanning the cache to find the correct location so that the +;; list can be fiddled. +(defun semantic-edits-splice-remove (oldtags parent cachelist) + "Remove OLDTAGS from PARENT's CACHELIST. +OLDTAGS are tags in the currenet buffer, preferably linked +together also in CACHELIST. +PARENT is the parent tag containing OLDTAGS. +CACHELIST should be the children from PARENT, but may be +pre-positioned to a convenient location." + (let* ((first (car oldtags)) + (last (nth (1- (length oldtags)) oldtags)) + (chil (if parent + (semantic-tag-components parent) + semantic--buffer-cache)) + (cachestart cachelist) + (cacheend nil) + ) + ;; First in child list? + (if (eq first (car chil)) + ;; First tags in the cache are being deleted. + (progn + (when semantic-edits-verbose-flag + (message "To Remove First Tag: (%s)" + (semantic-format-tag-name first))) + ;; Find the last tag + (setq cacheend chil) + (while (and cacheend (not (eq last (car cacheend)))) + (setq cacheend (cdr cacheend))) + ;; The splicable part is after cacheend.. so move cacheend + ;; one more tag. + (setq cacheend (cdr cacheend)) + ;; Splice the found end tag into the cons cell + ;; owned by the current top child. + (setcar chil (car cacheend)) + (setcdr chil (cdr cacheend)) + (when (not cacheend) + ;; No cacheend.. then the whole system is empty. + ;; The best way to deal with that is to do a full + ;; reparse + (semantic-parse-changes-failed "Splice-remove failed. Empty buffer?") + )) + (message "To Remove Middle Tag: (%s)" + (semantic-format-tag-name first))) + ;; Find in the cache the preceeding tag + (while (and cachestart (not (eq first (car (cdr cachestart))))) + (setq cachestart (cdr cachestart))) + ;; Find the last tag + (setq cacheend cachestart) + (while (and cacheend (not (eq last (car cacheend)))) + (setq cacheend (cdr cacheend))) + ;; Splice the end position into the start position. + ;; If there is no start, then this whole section is probably + ;; gone. + (if cachestart + (setcdr cachestart (cdr cacheend)) + (semantic-parse-changes-failed "Splice-remove failed.")) + + ;; Remove old overlays of these deleted tags + (while oldtags + (semantic--tag-unlink-from-buffer (car oldtags)) + (setq oldtags (cdr oldtags))) + )) + +(defun semantic-edits-splice-insert (newtags parent cachelist) + "Insert NEWTAGS into PARENT using CACHELIST. +PARENT could be nil, in which case CACHLIST is the buffer cache +which must be updated. +CACHELIST must be searched to find where NEWTAGS are to be inserted. +The positions of NEWTAGS must be synchronized with those in +CACHELIST for this to work. Some routines pre-position CACHLIST at a +convenient location, so use that." + (let* ((start (semantic-tag-start (car newtags))) + (newtagendcell (nthcdr (1- (length newtags)) newtags)) + (end (semantic-tag-end (car newtagendcell))) + ) + (if (> (semantic-tag-start (car cachelist)) start) + ;; We are at the beginning. + (let* ((pc (if parent + (semantic-tag-components parent) + semantic--buffer-cache)) + (nc (cons (car pc) (cdr pc))) ; new cons cell. + ) + ;; Splice the new cache cons cell onto the end of our list. + (setcdr newtagendcell nc) + ;; Set our list into parent. + (setcar pc (car newtags)) + (setcdr pc (cdr newtags))) + ;; We are at the end, or in the middle. Find our match first. + (while (and (cdr cachelist) + (> end (semantic-tag-start (car (cdr cachelist))))) + (setq cachelist (cdr cachelist))) + ;; Now splice into the list! + (setcdr newtagendcell (cdr cachelist)) + (setcdr cachelist newtags)))) + +(defun semantic-edits-splice-replace (oldtag newtag) + "Replace OLDTAG with NEWTAG in the current cache. +Do this by recycling OLDTAG's first CONS cell. This effectivly +causes the new tag to completely replace the old one. +Make sure that all information in the overlay is transferred. +It is presumed that OLDTAG and NEWTAG are both cooked. +When this routine returns, OLDTAG is raw, and the data will be +lost if not transferred into NEWTAG." + (let* ((oo (semantic-tag-overlay oldtag)) + (o (semantic-tag-overlay newtag)) + (oo-props (semantic-overlay-properties oo))) + (while oo-props + (semantic-overlay-put o (car oo-props) (car (cdr oo-props))) + (setq oo-props (cdr (cdr oo-props))) + ) + ;; Free the old overlay(s) + (semantic--tag-unlink-from-buffer oldtag) + ;; Recover properties + (semantic--tag-copy-properties oldtag newtag) + ;; Splice into the main list. + (setcdr oldtag (cdr newtag)) + (setcar oldtag (car newtag)) + ;; This important bit is because the CONS cell representing + ;; OLDTAG is now pointing to NEWTAG, but the NEWTAG + ;; cell is about to be abandoned. Here we update our overlay + ;; to point at the updated state of the world. + (semantic-overlay-put o 'semantic oldtag) + )) + +;;; Setup incremental parser +;; +(add-hook 'semantic-change-hooks + #'semantic-edits-change-function-handle-changes) +(add-hook 'semantic-before-toplevel-cache-flush-hook + #'semantic-edits-flush-changes) + +(provide 'semantic/edit) + +;;; semantic-edit.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/html.el Sat Aug 29 19:00:35 2009 +0000 @@ -0,0 +1,262 @@ +;;; html.el --- Semantic details for html files + +;;; Copyright (C) 2004, 2005, 2007, 2008 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Parse HTML files and organize them in a nice way. +;; Pay attention to anchors, including them in the tag list. +;; +;; Copied from the original semantic-texi.el. +;; +;; ToDo: Find <script> tags, and parse the contents in other +;; parsers, such as javascript, php, shtml, or others. + +(require 'semantic) +(require 'semantic/format) +(condition-case nil + ;; This is not installed in all versions of Emacs. + (require 'sgml-mode) ;; html-mode is in here. + (error + (require 'psgml-mode) ;; XEmacs uses psgml, and html-mode is in here. + )) + +;;; Code: +(eval-when-compile + (require 'semantic/ctxt) + (require 'semantic/imenu) + (require 'senator)) + +(defvar semantic-html-super-regex + "<\\(h[1-9]\\|title\\|script\\|body\\|a +href\\)\\>" + "Regular expression used to find special sections in an HTML file.") + +(defvar semantic-html-section-list + '(("title" 1) + ("script" 1) + ("body" 1) + ("a" 11) + ("h1" 2) + ("h2" 3) + ("h3" 4) + ("h4" 5) + ("h5" 6) + ("h6" 7) + ("h7" 8) + ("h8" 9) + ("h9" 10) + ) + "Alist of sectioning commands and their relative level.") + +(define-mode-local-override semantic-parse-region + html-mode (&rest ignore) + "Parse the current html buffer for semantic tags. +INGNORE any arguments. Always parse the whole buffer. +Each tag returned is of the form: + (\"NAME\" section (:members CHILDREN)) +or + (\"NAME\" anchor)" + (mapcar 'semantic-html-expand-tag + (semantic-html-parse-headings))) + +(define-mode-local-override semantic-parse-changes + html-mode () + "We can't parse changes for HTML mode right now." + (semantic-parse-tree-set-needs-rebuild)) + +(defun semantic-html-expand-tag (tag) + "Expand the HTML tag TAG." + (let ((chil (semantic-html-components tag))) + (if chil + (semantic-tag-put-attribute + tag :members (mapcar 'semantic-html-expand-tag chil))) + (car (semantic--tag-expand tag)))) + +(defun semantic-html-components (tag) + "Return components belonging to TAG." + (semantic-tag-get-attribute tag :members)) + +(defun semantic-html-parse-headings () + "Parse the current html buffer for all semantic tags." + (let ((pass1 nil)) + ;; First search and snarf. + (save-excursion + (goto-char (point-min)) + + (let ((semantic--progress-reporter + (make-progress-reporter + (format "Parsing %s..." + (file-name-nondirectory buffer-file-name)) + (point-min) (point-max)))) + (while (re-search-forward semantic-html-super-regex nil t) + (setq pass1 (cons (match-beginning 0) pass1)) + (progress-reporter-update semantic--progress-reporter (point))) + (progress-reporter-done semantic--progress-reporter))) + + (setq pass1 (nreverse pass1)) + ;; Now, make some tags while creating a set of children. + (car (semantic-html-recursive-combobulate-list pass1 0)) + )) + +(defun semantic-html-set-endpoint (metataglist pnt) + "Set the end point of the first section tag in METATAGLIST to PNT. +METATAGLIST is a list of tags in the intermediate tag format used by the +html parser. PNT is the new point to set." + (let ((metatag nil)) + (while (and metataglist + (not (eq (semantic-tag-class (car metataglist)) 'section))) + (setq metataglist (cdr metataglist))) + (setq metatag (car metataglist)) + (when metatag + (setcar (nthcdr (1- (length metatag)) metatag) pnt) + metatag))) + +(defsubst semantic-html-new-section-tag (name members level start end) + "Create a semantic tag of class section. +NAME is the name of this section. +MEMBERS is a list of semantic tags representing the elements that make +up this section. +LEVEL is the levelling level. +START and END define the location of data described by the tag." + (let ((anchorp (eq level 11))) + (append (semantic-tag name + (cond (anchorp 'anchor) + (t 'section)) + :members members) + (list start (if anchorp (point) end)) ))) + +(defun semantic-html-extract-section-name () + "Extract a section name from the current buffer and point. +Assume the cursor is in the tag representing the section we +need the name from." + (save-excursion + ; Skip over the HTML tag. + (forward-sexp -1) + (forward-char -1) + (forward-sexp 1) + (skip-chars-forward "\n\t ") + (while (looking-at "<") + (forward-sexp 1) + (skip-chars-forward "\n\t ") + ) + (let ((start (point)) + (end nil)) + (if (re-search-forward "</" nil t) + (progn + (goto-char (match-beginning 0)) + (skip-chars-backward " \n\t") + (setq end (point)) + (buffer-substring-no-properties start end)) + "")) + )) + +(defun semantic-html-recursive-combobulate-list (sectionlist level) + "Rearrange SECTIONLIST to be a hierarchical tag list starting at LEVEL. +Return the rearranged new list, with all remaining tags from +SECTIONLIST starting at ELT 2. Sections not are not dealt with as soon as a +tag with greater section value than LEVEL is found." + (let ((newl nil) + (oldl sectionlist) + (case-fold-search t) + tag + ) + (save-excursion + (catch 'level-jump + (while oldl + (goto-char (car oldl)) + (if (looking-at "<\\(\\w+\\)") + (let* ((word (match-string 1)) + (levelmatch (assoc-ignore-case + word semantic-html-section-list)) + text begin tmp + ) + (when (not levelmatch) + (error "Tag %s matched in regexp but is not in list" + word)) + ;; Set begin to the right location + (setq begin (point)) + ;; Get out of here if there if we made it that far. + (if (and levelmatch (<= (car (cdr levelmatch)) level)) + (progn + (when newl + (semantic-html-set-endpoint newl begin)) + (throw 'level-jump t))) + ;; When there is a match, the descriptive text + ;; consists of the rest of the line. + (goto-char (match-end 1)) + (skip-chars-forward " \t") + (setq text (semantic-html-extract-section-name)) + ;; Next, recurse into the body to find the end. + (setq tmp (semantic-html-recursive-combobulate-list + (cdr oldl) (car (cdr levelmatch)))) + ;; Build a tag + (setq tag (semantic-html-new-section-tag + text (car tmp) (car (cdr levelmatch)) begin (point-max))) + ;; Before appending the newtag, update the previous tag + ;; if it is a section tag. + (when newl + (semantic-html-set-endpoint newl begin)) + ;; Append new tag to our master list. + (setq newl (cons tag newl)) + ;; continue + (setq oldl (cdr tmp)) + ) + (error "Problem finding section in semantic/html parser")) + ;; (setq oldl (cdr oldl)) + ))) + ;; Return the list + (cons (nreverse newl) oldl))) + +(define-mode-local-override semantic-sb-tag-children-to-expand + html-mode (tag) + "The children TAG expands to." + (semantic-html-components tag)) + +(defun semantic-default-html-setup () + "Set up a buffer for parsing of HTML files." + ;; This will use our parser. + (setq semantic-parser-name "HTML" + semantic--parse-table t + imenu-create-index-function 'semantic-create-imenu-index + semantic-command-separation-character ">" + semantic-type-relation-separator-character '(":") + semantic-symbol->name-assoc-list '((section . "Section") + + ) + semantic-imenu-expandable-tag-classes '(section) + semantic-imenu-bucketize-file nil + semantic-imenu-bucketize-type-members nil + senator-step-at-start-end-tag-classes '(section) + semantic-stickyfunc-sticky-classes '(section) + ) + (semantic-install-function-overrides + '((tag-components . semantic-html-components) + ) + t) + ) + +(add-hook 'html-mode-hook 'semantic-default-html-setup) + +(define-child-mode html-helper-mode html-mode + "`html-helper-mode' needs the same semantic support as `html-mode'.") + +(provide 'semantic/html) + +;;; semantic-html.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/idle.el Sat Aug 29 19:00:35 2009 +0000 @@ -0,0 +1,957 @@ +;;; idle.el --- Schedule parsing tasks in idle time + +;;; Copyright (C) 2003, 2004, 2005, 2006, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Originally, `semantic-auto-parse-mode' handled refreshing the +;; tags in a buffer in idle time. Other activities can be scheduled +;; in idle time, all of which require up-to-date tag tables. +;; Having a specialized idle time scheduler that first refreshes +;; the tags buffer, and then enables other idle time tasks reduces +;; the amount of work needed. Any specialized idle tasks need not +;; ask for a fresh tags list. +;; +;; NOTE ON SEMANTIC_ANALYZE +;; +;; Some of the idle modes use the semantic analyzer. The analyzer +;; automatically caches the created context, so it is shared amongst +;; all idle modes that will need it. + +(require 'semantic/util-modes) +(require 'timer) + +;;; Code: + +;;; TIMER RELATED FUNCTIONS +;; +(defvar semantic-idle-scheduler-timer nil + "Timer used to schedule tasks in idle time.") + +(defvar semantic-idle-scheduler-work-timer nil + "Timer used to schedule tasks in idle time that may take a while.") + +(defcustom semantic-idle-scheduler-verbose-flag nil + "*Non-nil means that the idle scheduler should provide debug messages. +Use this setting to debug idle activities." + :group 'semantic + :type 'boolean) + +(defcustom semantic-idle-scheduler-idle-time 2 + "*Time in seconds of idle before scheduling events. +This time should be short enough to ensure that idle-scheduler will be +run as soon as Emacs is idle." + :group 'semantic + :type 'number + :set (lambda (sym val) + (set-default sym val) + (when (timerp semantic-idle-scheduler-timer) + (cancel-timer semantic-idle-scheduler-timer) + (setq semantic-idle-scheduler-timer nil) + (semantic-idle-scheduler-setup-timers)))) + +(defcustom semantic-idle-scheduler-work-idle-time 60 + "*Time in seconds of idle before scheduling big work. +This time should be long enough that once any big work is started, it is +unlikely the user would be ready to type again right away." + :group 'semantic + :type 'number + :set (lambda (sym val) + (set-default sym val) + (when (timerp semantic-idle-scheduler-timer) + (cancel-timer semantic-idle-scheduler-timer) + (setq semantic-idle-scheduler-timer nil) + (semantic-idle-scheduler-setup-timers)))) + +(defun semantic-idle-scheduler-setup-timers () + "Lazy initialization of the auto parse idle timer." + ;; REFRESH THIS FUNCTION for XEMACS FOIBLES + (or (timerp semantic-idle-scheduler-timer) + (setq semantic-idle-scheduler-timer + (run-with-idle-timer + semantic-idle-scheduler-idle-time t + #'semantic-idle-scheduler-function))) + (or (timerp semantic-idle-scheduler-work-timer) + (setq semantic-idle-scheduler-work-timer + (run-with-idle-timer + semantic-idle-scheduler-work-idle-time t + #'semantic-idle-scheduler-work-function))) + ) + +(defun semantic-idle-scheduler-kill-timer () + "Kill the auto parse idle timer." + (if (timerp semantic-idle-scheduler-timer) + (cancel-timer semantic-idle-scheduler-timer)) + (setq semantic-idle-scheduler-timer nil)) + + +;;; MINOR MODE +;; +;; The minor mode portion of this code just sets up the minor mode +;; which does the initial scheduling of the idle timers. +;; +(defcustom global-semantic-idle-scheduler-mode nil + "*If non-nil, enable global use of idle-scheduler mode." + :group 'semantic + :group 'semantic-modes + :type 'boolean + :require 'semantic/idle + :initialize 'custom-initialize-default + :set (lambda (sym val) + (global-semantic-idle-scheduler-mode (if val 1 -1)))) + +;;;###autoload +(defun global-semantic-idle-scheduler-mode (&optional arg) + "Toggle global use of option `semantic-idle-scheduler-mode'. +The idle scheduler with automatically reparse buffers in idle time, +and then schedule other jobs setup with `semantic-idle-scheduler-add'. +If ARG is positive, enable, if it is negative, disable. +If ARG is nil, then toggle." + (interactive "P") + (setq global-semantic-idle-scheduler-mode + (semantic-toggle-minor-mode-globally + 'semantic-idle-scheduler-mode arg))) + +(defcustom semantic-idle-scheduler-mode-hook nil + "*Hook run at the end of function `semantic-idle-scheduler-mode'." + :group 'semantic + :type 'hook) + +;;;###autoload +(defvar semantic-idle-scheduler-mode nil + "Non-nil if idle-scheduler minor mode is enabled. +Use the command `semantic-idle-scheduler-mode' to change this variable.") +(make-variable-buffer-local 'semantic-idle-scheduler-mode) + +(defcustom semantic-idle-scheduler-max-buffer-size 0 + "*Maximum size in bytes of buffers where idle-scheduler is enabled. +If this value is less than or equal to 0, idle-scheduler is enabled in +all buffers regardless of their size." + :group 'semantic + :type 'number) + +(defsubst semantic-idle-scheduler-enabled-p () + "Return non-nil if idle-scheduler is enabled for this buffer. +idle-scheduler is disabled when debugging or if the buffer size +exceeds the `semantic-idle-scheduler-max-buffer-size' threshold." + (and semantic-idle-scheduler-mode + (not semantic-debug-enabled) + (not semantic-lex-debug) + (or (<= semantic-idle-scheduler-max-buffer-size 0) + (< (buffer-size) semantic-idle-scheduler-max-buffer-size)))) + +(defun semantic-idle-scheduler-mode-setup () + "Setup option `semantic-idle-scheduler-mode'. +The minor mode can be turned on only if semantic feature is available +and the current buffer was set up for parsing. When minor mode is +enabled parse the current buffer if needed. Return non-nil if the +minor mode is enabled." + (if semantic-idle-scheduler-mode + (if (not (and (featurep 'semantic) (semantic-active-p))) + (progn + ;; Disable minor mode if semantic stuff not available + (setq semantic-idle-scheduler-mode nil) + (error "Buffer %s was not set up idle time scheduling" + (buffer-name))) + (semantic-idle-scheduler-setup-timers))) + semantic-idle-scheduler-mode) + +;;;###autoload +(defun semantic-idle-scheduler-mode (&optional arg) + "Minor mode to auto parse buffer following a change. +When this mode is off, a buffer is only rescanned for tokens when +some command requests the list of available tokens. When idle-scheduler +is enabled, Emacs periodically checks to see if the buffer is out of +date, and reparses while the user is idle (not typing.) + +With prefix argument ARG, turn on if positive, otherwise off. The +minor mode can be turned on only if semantic feature is available and +the current buffer was set up for parsing. Return non-nil if the +minor mode is enabled." + (interactive + (list (or current-prefix-arg + (if semantic-idle-scheduler-mode 0 1)))) + (setq semantic-idle-scheduler-mode + (if arg + (> + (prefix-numeric-value arg) + 0) + (not semantic-idle-scheduler-mode))) + (semantic-idle-scheduler-mode-setup) + (run-hooks 'semantic-idle-scheduler-mode-hook) + (if (interactive-p) + (message "idle-scheduler minor mode %sabled" + (if semantic-idle-scheduler-mode "en" "dis"))) + (semantic-mode-line-update) + semantic-idle-scheduler-mode) + +(semantic-add-minor-mode 'semantic-idle-scheduler-mode + "ARP" + nil) + +(semantic-alias-obsolete 'semantic-auto-parse-mode + 'semantic-idle-scheduler-mode) +(semantic-alias-obsolete 'global-semantic-auto-parse-mode + 'global-semantic-idle-scheduler-mode) + + +;;; SERVICES services +;; +;; These are services for managing idle services. +;; +(defvar semantic-idle-scheduler-queue nil + "List of functions to execute during idle time. +These functions will be called in the current buffer after that +buffer has had its tags made up to date. These functions +will not be called if there are errors parsing the +current buffer.") + +;;;###autoload +(defun semantic-idle-scheduler-add (function) + "Schedule FUNCTION to occur during idle time." + (add-to-list 'semantic-idle-scheduler-queue function)) + +;;;###autoload +(defun semantic-idle-scheduler-remove (function) + "Unschedule FUNCTION to occur during idle time." + (setq semantic-idle-scheduler-queue + (delete function semantic-idle-scheduler-queue))) + +;;; IDLE Function +;; +(defun semantic-idle-core-handler () + "Core idle function that handles reparsing. +And also manages services that depend on tag values." + (when semantic-idle-scheduler-verbose-flag + (message "IDLE: Core handler...")) + (semantic-exit-on-input 'idle-timer + (let* ((inhibit-quit nil) + (buffers (delq (current-buffer) + (delq nil + (mapcar #'(lambda (b) + (and (buffer-file-name b) + b)) + (buffer-list))))) + safe ;; This safe is not used, but could be. + others + mode) + (when (semantic-idle-scheduler-enabled-p) + (save-excursion + ;; First, reparse the current buffer. + (setq mode major-mode + safe (semantic-safe "Idle Parse Error: %S" + ;(error "Goofy error 1") + (semantic-idle-scheduler-refresh-tags) + ) + ) + ;; Now loop over other buffers with same major mode, trying to + ;; update them as well. Stop on keypress. + (dolist (b buffers) + (semantic-throw-on-input 'parsing-mode-buffers) + (with-current-buffer b + (if (eq major-mode mode) + (and (semantic-idle-scheduler-enabled-p) + (semantic-safe "Idle Parse Error: %S" + ;(error "Goofy error") + (semantic-idle-scheduler-refresh-tags))) + (push (current-buffer) others)))) + (setq buffers others)) + ;; If re-parse of current buffer completed, evaluate all other + ;; services. Stop on keypress. + + ;; NOTE ON COMMENTED SAFE HERE + ;; We used to not execute the services if the buffer wsa + ;; unparseable. We now assume that they are lexically + ;; safe to do, because we have marked the buffer unparseable + ;; if there was a problem. + ;;(when safe + (dolist (service semantic-idle-scheduler-queue) + (save-excursion + (semantic-throw-on-input 'idle-queue) + (when semantic-idle-scheduler-verbose-flag + (message "IDLE: execture service %s..." service)) + (semantic-safe (format "Idle Service Error %s: %%S" service) + (funcall service)) + (when semantic-idle-scheduler-verbose-flag + (message "IDLE: execture service %s...done" service)) + ))) + ;;) + ;; Finally loop over remaining buffers, trying to update them as + ;; well. Stop on keypress. + (save-excursion + (dolist (b buffers) + (semantic-throw-on-input 'parsing-other-buffers) + (with-current-buffer b + (and (semantic-idle-scheduler-enabled-p) + (semantic-idle-scheduler-refresh-tags))))) + )) + (when semantic-idle-scheduler-verbose-flag + (message "IDLE: Core handler...done"))) + +(defun semantic-debug-idle-function () + "Run the Semantic idle function with debugging turned on." + (interactive) + (let ((debug-on-error t)) + (semantic-idle-core-handler) + )) + +(defun semantic-idle-scheduler-function () + "Function run when after `semantic-idle-scheduler-idle-time'. +This function will reparse the current buffer, and if successful, +call additional functions registered with the timer calls." + (when (zerop (recursion-depth)) + (let ((debug-on-error nil)) + (save-match-data (semantic-idle-core-handler)) + ))) + + +;;; WORK FUNCTION +;; +;; Unlike the shorter timer, the WORK timer will kick of tasks that +;; may take a long time to complete. +(defcustom semantic-idle-work-parse-neighboring-files-flag t + "*Non-nil means to parse files in the same dir as the current buffer. +Disable to prevent lots of excessive parsing in idle time." + :group 'semantic + :type 'boolean) + + +(defun semantic-idle-work-for-one-buffer (buffer) + "Do long-processing work for for BUFFER. +Uses `semantic-safe' and returns the output. +Returns t of all processing succeeded." + (save-excursion + (set-buffer buffer) + (not (and + ;; Just in case + (semantic-safe "Idle Work Parse Error: %S" + (semantic-idle-scheduler-refresh-tags) + t) + + ;; Force all our include files to get read in so we + ;; are ready to provide good smart completion and idle + ;; summary information + (semantic-safe "Idle Work Including Error: %S" + ;; Get the include related path. + (when (and (featurep 'semantic/db) + (semanticdb-minor-mode-p)) + (require 'semantic/db-find) + (semanticdb-find-translate-path buffer nil) + ) + t) + + ;; Pre-build the typecaches as needed. + (semantic-safe "Idle Work Typecaching Error: %S" + (when (featurep 'semantic/db-typecache) + (semanticdb-typecache-refresh-for-buffer buffer)) + t) + )) + )) + +(defun semantic-idle-work-core-handler () + "Core handler for idle work processing of long running tasks. +Visits semantic controlled buffers, and makes sure all needed +include files have been parsed, and that the typecache is up to date. +Uses `semantic-idle-work-for-on-buffer' to do the work." + (let ((errbuf nil) + (interrupted + (semantic-exit-on-input 'idle-work-timer + (let* ((inhibit-quit nil) + (cb (current-buffer)) + (buffers (delq (current-buffer) + (delq nil + (mapcar #'(lambda (b) + (and (buffer-file-name b) + b)) + (buffer-list))))) + safe errbuf) + ;; First, handle long tasks in the current buffer. + (when (semantic-idle-scheduler-enabled-p) + (save-excursion + (setq safe (semantic-idle-work-for-one-buffer (current-buffer)) + ))) + (when (not safe) (push (current-buffer) errbuf)) + + ;; Now loop over other buffers with same major mode, trying to + ;; update them as well. Stop on keypress. + (dolist (b buffers) + (semantic-throw-on-input 'parsing-mode-buffers) + (with-current-buffer b + (when (semantic-idle-scheduler-enabled-p) + (and (semantic-idle-scheduler-enabled-p) + (unless (semantic-idle-work-for-one-buffer (current-buffer)) + (push (current-buffer) errbuf))) + )) + ) + + ;; Save everything. + (semanticdb-save-all-db-idle) + + ;; Parse up files near our active buffer + (when semantic-idle-work-parse-neighboring-files-flag + (semantic-safe "Idle Work Parse Neighboring Files: %S" + (when (and (featurep 'semantic/db) + (semanticdb-minor-mode-p)) + (set-buffer cb) + (semantic-idle-scheduler-work-parse-neighboring-files)) + t) + ) + + ;; Save everything... again + (semanticdb-save-all-db-idle) + + ;; Done w/ processing + nil)))) + + ;; Done + (if interrupted + "Interrupted" + (cond ((not errbuf) + "done") + ((not (cdr errbuf)) + (format "done with 1 error in %s" (car errbuf))) + (t + (format "done with errors in %d buffers." + (length errbuf))))))) + +(defun semantic-debug-idle-work-function () + "Run the Semantic idle work function with debugging turned on." + (interactive) + (let ((debug-on-error t)) + (semantic-idle-work-core-handler) + )) + +(defun semantic-idle-scheduler-work-function () + "Function run when after `semantic-idle-scheduler-work-idle-time'. +This routine handles difficult tasks that require a lot of parsing, such as +parsing all the header files used by our active sources, or building up complex +datasets." + (when semantic-idle-scheduler-verbose-flag + (message "Long Work Idle Timer...")) + (let ((exit-type (save-match-data + (semantic-idle-work-core-handler)))) + (when semantic-idle-scheduler-verbose-flag + (message "Long Work Idle Timer...%s" exit-type))) + ) + +(defun semantic-idle-scheduler-work-parse-neighboring-files () + "Parse all the files in similar directories to buffers being edited." + ;; Lets check to see if EDE matters. + (let ((ede-auto-add-method 'never)) + (dolist (a auto-mode-alist) + (when (eq (cdr a) major-mode) + (dolist (file (directory-files default-directory t (car a) t)) + (semantic-throw-on-input 'parsing-mode-buffers) + (save-excursion + (semanticdb-file-table-object file) + )))) + )) + +(defun semantic-idle-pnf-test () + "Test `semantic-idle-scheduler-work-parse-neighboring-files' and time it." + (interactive) + (let ((start (current-time)) + (junk (semantic-idle-scheduler-work-parse-neighboring-files)) + (end (current-time))) + (message "Work took %.2f seconds." (semantic-elapsed-time start end))) + ) + + +;;; REPARSING +;; +;; Reparsing is installed as semantic idle service. +;; This part ALWAYS happens, and other services occur +;; afterwards. + +;; (defcustom semantic-idle-scheduler-no-working-message t +;; "*If non-nil, disable display of working messages during parse." +;; :group 'semantic +;; :type 'boolean) + +;; (defcustom semantic-idle-scheduler-working-in-modeline-flag nil +;; "*Non-nil means show working messages in the mode line. +;; Typically, parsing will show messages in the minibuffer. +;; This will move the parse message into the modeline." +;; :group 'semantic +;; :type 'boolean) + +(defvar semantic-before-idle-scheduler-reparse-hooks nil + "Hooks run before option `semantic-idle-scheduler' begins parsing. +If any hook throws an error, this variable is reset to nil. +This hook is not protected from lexical errors.") + +(defvar semantic-after-idle-scheduler-reparse-hooks nil + "Hooks run after option `semantic-idle-scheduler' has parsed. +If any hook throws an error, this variable is reset to nil. +This hook is not protected from lexical errors.") + +(defun semantic-idle-scheduler-refresh-tags () + "Refreshes the current buffer's tags. +This is called by `semantic-idle-scheduler-function' to update the +tags in the current buffer. + +Return non-nil if the refresh was successful. +Return nil if there is some sort of syntax error preventing a full +reparse. + +Does nothing if the current buffer doesn't need reparsing." + + (prog1 + ;; These checks actually occur in `semantic-fetch-tags', but if we + ;; do them here, then all the bovination hooks are not run, and + ;; we save lots of time. + (cond + ;; If the buffer was previously marked unparseable, + ;; then don't waste our time. + ((semantic-parse-tree-unparseable-p) + nil) + ;; The parse tree is already ok. + ((semantic-parse-tree-up-to-date-p) + t) + (t + ;; If the buffer might need a reparse and it is safe to do so, + ;; give it a try. + (let* (;(semantic-working-type nil) + (inhibit-quit nil) + ;; (working-use-echo-area-p + ;; (not semantic-idle-scheduler-working-in-modeline-flag)) + ;; (working-status-dynamic-type + ;; (if semantic-idle-scheduler-no-working-message + ;; nil + ;; working-status-dynamic-type)) + ;; (working-status-percentage-type + ;; (if semantic-idle-scheduler-no-working-message + ;; nil + ;; working-status-percentage-type)) + (lexically-safe t) + ) + ;; Let people hook into this, but don't let them hose + ;; us over! + (condition-case nil + (run-hooks 'semantic-before-idle-scheduler-reparse-hooks) + (error (setq semantic-before-idle-scheduler-reparse-hooks nil))) + + (unwind-protect + ;; Perform the parsing. + (progn + (when semantic-idle-scheduler-verbose-flag + (message "IDLE: reparse %s..." (buffer-name))) + (when (semantic-lex-catch-errors idle-scheduler + (save-excursion (semantic-fetch-tags)) + nil) + ;; If we are here, it is because the lexical step failed, + ;; proably due to unterminated lists or something like that. + + ;; We do nothing, and just wait for the next idle timer + ;; to go off. In the meantime, remember this, and make sure + ;; no other idle services can get executed. + (setq lexically-safe nil)) + (when semantic-idle-scheduler-verbose-flag + (message "IDLE: reparse %s...done" (buffer-name)))) + ;; Let people hook into this, but don't let them hose + ;; us over! + (condition-case nil + (run-hooks 'semantic-after-idle-scheduler-reparse-hooks) + (error (setq semantic-after-idle-scheduler-reparse-hooks nil)))) + ;; Return if we are lexically safe (from prog1) + lexically-safe))) + + ;; After updating the tags, handle any pending decorations for this + ;; buffer. + (semantic-decorate-flush-pending-decorations (current-buffer)) + )) + + +;;; IDLE SERVICES +;; +;; Idle Services are minor modes which enable or disable a services in +;; the idle scheduler. Creating a new services only requires calling +;; `semantic-create-idle-services' which does all the setup +;; needed to create the minor mode that will enable or disable +;; a services. The services must provide a single function. + +(defmacro define-semantic-idle-service (name doc &rest forms) + "Create a new idle services with NAME. +DOC will be a documentation string describing FORMS. +FORMS will be called during idle time after the current buffer's +semantic tag information has been updated. +This routines creates the following functions and variables:" + (let ((global (intern (concat "global-" (symbol-name name) "-mode"))) + (mode (intern (concat (symbol-name name) "-mode"))) + (hook (intern (concat (symbol-name name) "-mode-hook"))) + (map (intern (concat (symbol-name name) "-mode-map"))) + (setup (intern (concat (symbol-name name) "-mode-setup"))) + (func (intern (concat (symbol-name name) "-idle-function"))) + ) + + `(eval-and-compile + (defun ,global (&optional arg) + ,(concat "Toggle global use of option `" (symbol-name mode) "'. +If ARG is positive, enable, if it is negative, disable. +If ARG is nil, then toggle.") + (interactive "P") + (setq ,global + (semantic-toggle-minor-mode-globally + ',mode arg))) + + (defcustom ,global nil + (concat "*If non-nil, enable global use of `" (symbol-name ',mode) "'. +" ,doc) + :group 'semantic + :group 'semantic-modes + :type 'boolean + :require 'semantic/idle + :initialize 'custom-initialize-default + :set (lambda (sym val) + (,global (if val 1 -1)))) + + (defcustom ,hook nil + (concat "*Hook run at the end of function `" (symbol-name ',mode) "'.") + :group 'semantic + :type 'hook) + + (defvar ,map + (let ((km (make-sparse-keymap))) + km) + (concat "Keymap for `" (symbol-name ',mode) "'.")) + + (defvar ,mode nil + (concat "Non-nil if summary minor mode is enabled. +Use the command `" (symbol-name ',mode) "' to change this variable.")) + (make-variable-buffer-local ',mode) + + (defun ,setup () + ,(concat "Setup option `" (symbol-name mode) "'. +The minor mode can be turned on only if semantic feature is available +and the idle scheduler is active. +Return non-nil if the minor mode is enabled.") + (if ,mode + (if (not (and (featurep 'semantic) (semantic-active-p))) + (progn + ;; Disable minor mode if semantic stuff not available + (setq ,mode nil) + (error "Buffer %s was not set up for parsing" + (buffer-name))) + ;; Enable the mode mode + (semantic-idle-scheduler-add #',func) + ) + ;; Disable the mode mode + (semantic-idle-scheduler-remove #',func) + ) + ,mode) + +;;;###autoload + (defun ,mode (&optional arg) + ,(concat doc " +This is a minor mode which performs actions during idle time. +With prefix argument ARG, turn on if positive, otherwise off. The +minor mode can be turned on only if semantic feature is available and +the current buffer was set up for parsing. Return non-nil if the +minor mode is enabled.") + (interactive + (list (or current-prefix-arg + (if ,mode 0 1)))) + (setq ,mode + (if arg + (> + (prefix-numeric-value arg) + 0) + (not ,mode))) + (,setup) + (run-hooks ,hook) + (if (interactive-p) + (message "%s %sabled" + (symbol-name ',mode) + (if ,mode "en" "dis"))) + (semantic-mode-line-update) + ,mode) + + (semantic-add-minor-mode ',mode + "" ; idle schedulers are quiet? + ,map) + + (defun ,func () + ,doc + ,@forms) + + ))) +(put 'define-semantic-idle-service 'lisp-indent-function 1) + + +;;; SUMMARY MODE +;; +;; A mode similar to eldoc using semantic +(require 'semantic/ctxt) + +(defcustom semantic-idle-summary-function + 'semantic-format-tag-summarize-with-file + "*Function to use when displaying tag information during idle time. +Some useful functions are found in `semantic-format-tag-functions'." + :group 'semantic + :type semantic-format-tag-custom-list) + +(defsubst semantic-idle-summary-find-current-symbol-tag (sym) + "Search for a semantic tag with name SYM in database tables. +Return the tag found or nil if not found. +If semanticdb is not in use, use the current buffer only." + (car (if (and (featurep 'semantic/db) semanticdb-current-database) + (cdar (semanticdb-deep-find-tags-by-name sym)) + (semantic-deep-find-tags-by-name sym (current-buffer))))) + +(defun semantic-idle-summary-current-symbol-info-brutish () + "Return a string message describing the current context. +Gets a symbol with `semantic-ctxt-current-thing' and then +trys to find it with a deep targetted search." + ;; Try the current "thing". + (let ((sym (car (semantic-ctxt-current-thing)))) + (when sym + (semantic-idle-summary-find-current-symbol-tag sym)))) + +(defun semantic-idle-summary-current-symbol-keyword () + "Return a string message describing the current symbol. +Returns a value only if it is a keyword." + ;; Try the current "thing". + (let ((sym (car (semantic-ctxt-current-thing)))) + (if (and sym (semantic-lex-keyword-p sym)) + (semantic-lex-keyword-get sym 'summary)))) + +(defun semantic-idle-summary-current-symbol-info-context () + "Return a string message describing the current context. +Use the semantic analyzer to find the symbol information." + (let ((analysis (condition-case nil + (semantic-analyze-current-context (point)) + (error nil)))) + (when analysis + (semantic-analyze-interesting-tag analysis)))) + +(defun semantic-idle-summary-current-symbol-info-default () + "Return a string message describing the current context. +This functin will disable loading of previously unloaded files +by semanticdb as a time-saving measure." + (let ( + (semanticdb-find-default-throttle + (if (featurep 'semantic/db-find) + (remq 'unloaded semanticdb-find-default-throttle) + nil)) + ) + (save-excursion + ;; use whicever has success first. + (or + (semantic-idle-summary-current-symbol-keyword) + + (semantic-idle-summary-current-symbol-info-context) + + (semantic-idle-summary-current-symbol-info-brutish) + )))) + +(defvar semantic-idle-summary-out-of-context-faces + '( + font-lock-comment-face + font-lock-string-face + font-lock-doc-string-face ; XEmacs. + font-lock-doc-face ; Emacs 21 and later. + ) + "List of font-lock faces that indicate a useless summary context. +Those are generally faces used to highlight comments. + +It might be useful to override this variable to add comment faces +specific to a major mode. For example, in jde mode: + +\(defvar-mode-local jde-mode semantic-idle-summary-out-of-context-faces + (append (default-value 'semantic-idle-summary-out-of-context-faces) + '(jde-java-font-lock-doc-tag-face + jde-java-font-lock-link-face + jde-java-font-lock-bold-face + jde-java-font-lock-underline-face + jde-java-font-lock-pre-face + jde-java-font-lock-code-face)))") + +(defun semantic-idle-summary-useful-context-p () + "Non-nil of we should show a summary based on context." + (if (and (boundp 'font-lock-mode) + font-lock-mode + (memq (get-text-property (point) 'face) + semantic-idle-summary-out-of-context-faces)) + ;; The best I can think of at the moment is to disable + ;; in comments by detecting with font-lock. + nil + t)) + +(define-overloadable-function semantic-idle-summary-current-symbol-info () + "Return a string message describing the current context.") + +(make-obsolete-overload 'semantic-eldoc-current-symbol-info + 'semantic-idle-summary-current-symbol-info) + +(define-semantic-idle-service semantic-idle-summary + "Display a tag summary of the lexical token under the cursor. +Call `semantic-idle-summary-current-symbol-info' for getting the +current tag to display information." + (or (eq major-mode 'emacs-lisp-mode) + (not (semantic-idle-summary-useful-context-p)) + (let* ((found (semantic-idle-summary-current-symbol-info)) + (str (cond ((stringp found) found) + ((semantic-tag-p found) + (funcall semantic-idle-summary-function + found nil t)))) + ) + ;; Show the message with eldoc functions + (require 'eldoc) + (unless (and str (boundp 'eldoc-echo-area-use-multiline-p) + eldoc-echo-area-use-multiline-p) + (let ((w (1- (window-width (minibuffer-window))))) + (if (> (length str) w) + (setq str (substring str 0 w))))) + (eldoc-message str)))) + +(semantic-alias-obsolete 'semantic-summary-mode + 'semantic-idle-summary-mode) +(semantic-alias-obsolete 'global-semantic-summary-mode + 'global-semantic-idle-summary-mode) + +;;; Current symbol highlight +;; +;; This mode will use context analysis to perform highlighting +;; of all uses of the symbol that is under the cursor. +;; +;; This is to mimic the Eclipse tool of a similar nature. +(defvar semantic-idle-summary-highlight-face 'region + "Face used for the summary highlight.") + +(defun semantic-idle-summary-maybe-highlight (tag) + "Perhaps add highlighting onto TAG. +TAG was found as the thing under point. If it happens to be +visible, then highlight it." + (let* ((region (when (and (semantic-tag-p tag) + (semantic-tag-with-position-p tag)) + (semantic-tag-overlay tag))) + (file (when (and (semantic-tag-p tag) + (semantic-tag-with-position-p tag)) + (semantic-tag-file-name tag))) + (buffer (when file (get-file-buffer file))) + ;; We use pulse, but we don't want the flashy version, + ;; just the stable version. + (pulse-flag nil) + ) + (cond ((semantic-overlay-p region) + (save-excursion + (set-buffer (semantic-overlay-buffer region)) + (goto-char (semantic-overlay-start region)) + (when (pos-visible-in-window-p + (point) (get-buffer-window (current-buffer) 'visible)) + (if (< (semantic-overlay-end region) (point-at-eol)) + (pulse-momentary-highlight-overlay + region semantic-idle-summary-highlight-face) + ;; Not the same + (pulse-momentary-highlight-region + (semantic-overlay-start region) + (point-at-eol) + semantic-idle-summary-highlight-face))) + )) + ((vectorp region) + (let ((start (aref region 0)) + (end (aref region 1))) + (save-excursion + (when buffer (set-buffer buffer)) + ;; As a vector, we have no filename. Perhaps it is a + ;; local variable? + (when (and (<= end (point-max)) + (pos-visible-in-window-p + start (get-buffer-window (current-buffer) 'visible))) + (goto-char start) + (when (re-search-forward + (regexp-quote (semantic-tag-name tag)) + end t) + ;; This is likely it, give it a try. + (pulse-momentary-highlight-region + start (if (<= end (point-at-eol)) end + (point-at-eol)) + semantic-idle-summary-highlight-face))) + )))) + nil)) + +(define-semantic-idle-service semantic-idle-tag-highlight + "Highlight the tag, and references of the symbol under point. +Call `semantic-analyze-current-context' to find the reference tag. +Call `semantic-symref-hits-in-region' to identify local references." + (when (semantic-idle-summary-useful-context-p) + (let* ((ctxt (semantic-analyze-current-context)) + (Hbounds (when ctxt (oref ctxt bounds))) + (target (when ctxt (car (reverse (oref ctxt prefix))))) + (tag (semantic-current-tag)) + ;; We use pulse, but we don't want the flashy version, + ;; just the stable version. + (pulse-flag nil)) + (when ctxt + ;; Highlight the original tag? Protect against problems. + (condition-case nil + (semantic-idle-summary-maybe-highlight target) + (error nil)) + ;; Identify all hits in this current tag. + (when (semantic-tag-p target) + (semantic-symref-hits-in-region + target (lambda (start end prefix) + (when (/= start (car Hbounds)) + (pulse-momentary-highlight-region + start end)) + (semantic-throw-on-input 'symref-highlight) + ) + (semantic-tag-start tag) + (semantic-tag-end tag))) + )))) + + +;;; Completion Popup Mode +;; +;; This mode uses tooltips to display a (hopefully) short list of possible +;; completions available for the text under point. It provides +;; NO provision for actually filling in the values from those completions. + +(defun semantic-idle-completion-list-default () + "Calculate and display a list of completions." + (when (semantic-idle-summary-useful-context-p) + ;; This mode can be fragile. Ignore problems. + ;; If something doesn't do what you expect, run + ;; the below command by hand instead. + (condition-case nil + (let ( + ;; Don't go loading in oodles of header libraries in + ;; IDLE time. + (semanticdb-find-default-throttle + (if (featurep 'semantic/db-find) + (remq 'unloaded semanticdb-find-default-throttle) + nil)) + ) + ;; Use idle version. + (semantic-complete-analyze-inline-idle) + ) + (error nil)) + )) + +(define-semantic-idle-service semantic-idle-completions + "Display a list of possible completions in a tooltip." + ;; Add the ability to override sometime. + (semantic-idle-completion-list-default)) + +(provide 'semantic/idle) + +;;; semantic-idle.el ends here
--- a/lisp/cedet/semantic/lex.el Sat Aug 29 00:43:12 2009 +0000 +++ b/lisp/cedet/semantic/lex.el Sat Aug 29 19:00:35 2009 +0000 @@ -315,6 +315,42 @@ #'(lambda (symbol) (setq keywords (cons symbol keywords))) property) keywords)) + +;;; Inline functions: + +(defvar semantic-lex-unterminated-syntax-end-function) +(defvar semantic-lex-analysis-bounds) +(defvar semantic-lex-end-point) + +(defsubst semantic-lex-token-bounds (token) + "Fetch the start and end locations of the lexical token TOKEN. +Return a pair (START . END)." + (if (not (numberp (car (cdr token)))) + (cdr (cdr token)) + (cdr token))) + +(defsubst semantic-lex-token-start (token) + "Fetch the start position of the lexical token TOKEN. +See also the function `semantic-lex-token'." + (car (semantic-lex-token-bounds token))) + +(defsubst semantic-lex-token-end (token) + "Fetch the end position of the lexical token TOKEN. +See also the function `semantic-lex-token'." + (cdr (semantic-lex-token-bounds token))) + +(defsubst semantic-lex-unterminated-syntax-detected (syntax) + "Inside a lexical analyzer, use this when unterminated syntax was found. +Argument SYNTAX indicates the type of syntax that is unterminated. +The job of this function is to move (point) to a new logical location +so that analysis can continue, if possible." + (goto-char + (funcall semantic-lex-unterminated-syntax-end-function + syntax + (car semantic-lex-analysis-bounds) + (cdr semantic-lex-analysis-bounds) + )) + (setq semantic-lex-end-point (point))) ;;; Type table handling. ;; @@ -1012,23 +1048,6 @@ See also the function `semantic-lex-token'." (car token)) -(defsubst semantic-lex-token-bounds (token) - "Fetch the start and end locations of the lexical token TOKEN. -Return a pair (START . END)." - (if (not (numberp (car (cdr token)))) - (cdr (cdr token)) - (cdr token))) - -(defsubst semantic-lex-token-start (token) - "Fetch the start position of the lexical token TOKEN. -See also the function `semantic-lex-token'." - (car (semantic-lex-token-bounds token))) - -(defsubst semantic-lex-token-end (token) - "Fetch the end position of the lexical token TOKEN. -See also the function `semantic-lex-token'." - (cdr (semantic-lex-token-bounds token))) - (defsubst semantic-lex-token-text (token) "Fetch the text associated with the lexical token TOKEN. See also the function `semantic-lex-token'." @@ -1084,19 +1103,6 @@ ;; Created analyzers become variables with the code associated with them ;; as the symbol value. These analyzers are assembled into a lexer ;; to create new lexical analyzers. -;; -(defsubst semantic-lex-unterminated-syntax-detected (syntax) - "Inside a lexical analyzer, use this when unterminated syntax was found. -Argument SYNTAX indicates the type of syntax that is unterminated. -The job of this function is to move (point) to a new logical location -so that analysis can continue, if possible." - (goto-char - (funcall semantic-lex-unterminated-syntax-end-function - syntax - (car semantic-lex-analysis-bounds) - (cdr semantic-lex-analysis-bounds) - )) - (setq semantic-lex-end-point (point))) (defcustom semantic-lex-debug-analyzers nil "Non nil means to debug analyzers with syntax protection.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/texi.el Sat Aug 29 19:00:35 2009 +0000 @@ -0,0 +1,677 @@ +;;; texi.el --- Semantic details for Texinfo files + +;;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Parse Texinfo buffers using regular expressions. The core parser +;; engine is the function `semantic-texi-parse-headings'. The +;; parser plug-in is the function `semantic-texi-parse-region' that +;; overrides `semantic-parse-region'. + +(require 'semantic) +(require 'semantic/format) +(require 'texinfo) + +(eval-when-compile + (require 'semantic/db) + (require 'semantic/db-find) + (require 'semantic/ctxt) + (require 'semantic/imenu) + (require 'semantic/doc) + (require 'senator)) + +(defvar semantic-texi-super-regex + "^@\\(top\\|chapter\\|\\(sub\\)*section\\|unnumbered\\(\\(sub\\)*sec\\)?\\|\ +\\(chap\\|\\(sub\\)+\\|major\\)?heading\\|appendix\\(\\(sub\\)*sec\\)?\\|\ +centerchap\\|def\\(var\\|un\\|fn\\|opt\\)x?\\)" + "Regular expression used to find special sections in a Texinfo file.") + +(defvar semantic-texi-name-field-list + '( ("defvar" . 1) + ("defvarx" . 1) + ("defun" . 1) + ("defunx" . 1) + ("defopt" . 1) + ("deffn" . 2) + ("deffnx" . 2) + ) + "List of definition commands, and the field position. +The field position is the field number (based at 1) where the +name of this section is.") + +;;; Code: +(defun semantic-texi-parse-region (&rest ignore) + "Parse the current texinfo buffer for semantic tags. +IGNORE any arguments, always parse the whole buffer. +Each tag returned is of the form: + (\"NAME\" section (:members CHILDREN)) +or + (\"NAME\" def) + +It is an override of 'parse-region and must be installed by the +function `semantic-install-function-overrides'." + (mapcar 'semantic-texi-expand-tag + (semantic-texi-parse-headings))) + +(defun semantic-texi-parse-changes () + "Parse changes in the current texinfo buffer." + ;; NOTE: For now, just schedule a full reparse. + ;; To be implemented later. + (semantic-parse-tree-set-needs-rebuild)) + +(defun semantic-texi-expand-tag (tag) + "Expand the texinfo tag TAG." + (let ((chil (semantic-tag-components tag))) + (if chil + (semantic-tag-put-attribute + tag :members (mapcar 'semantic-texi-expand-tag chil))) + (car (semantic--tag-expand tag)))) + +(defun semantic-texi-parse-headings () + "Parse the current texinfo buffer for all semantic tags now." + (let ((pass1 nil)) + ;; First search and snarf. + (save-excursion + (goto-char (point-min)) + (let ((semantic--progress-reporter + (make-progress-reporter + (format "Parsing %s..." + (file-name-nondirectory buffer-file-name)) + (point-min) (point-max)))) + (while (re-search-forward semantic-texi-super-regex nil t) + (setq pass1 (cons (match-beginning 0) pass1)) + (progress-reporter-update semantic--progress-reporter (point))) + (progress-reporter-done semantic--progress-reporter))) + (setq pass1 (nreverse pass1)) + ;; Now, make some tags while creating a set of children. + (car (semantic-texi-recursive-combobulate-list pass1 0)) + )) + +(defsubst semantic-texi-new-section-tag (name members start end) + "Create a semantic tag of class section. +NAME is the name of this section. +MEMBERS is a list of semantic tags representing the elements that make +up this section. +START and END define the location of data described by the tag." + (append (semantic-tag name 'section :members members) + (list start end))) + +(defsubst semantic-texi-new-def-tag (name start end) + "Create a semantic tag of class def. +NAME is the name of this definition. +START and END define the location of data described by the tag." + (append (semantic-tag name 'def) + (list start end))) + +(defun semantic-texi-set-endpoint (metataglist pnt) + "Set the end point of the first section tag in METATAGLIST to PNT. +METATAGLIST is a list of tags in the intermediate tag format used by the +texinfo parser. PNT is the new point to set." + (let ((metatag nil)) + (while (and metataglist + (not (eq (semantic-tag-class (car metataglist)) 'section))) + (setq metataglist (cdr metataglist))) + (setq metatag (car metataglist)) + (when metatag + (setcar (nthcdr (1- (length metatag)) metatag) pnt) + metatag))) + +(defun semantic-texi-recursive-combobulate-list (sectionlist level) + "Rearrange SECTIONLIST to be a hierarchical tag list starting at LEVEL. +Return the rearranged new list, with all remaining tags from +SECTIONLIST starting at ELT 2. Sections not are not dealt with as soon as a +tag with greater section value than LEVEL is found." + (let ((newl nil) + (oldl sectionlist) + tag + ) + (save-excursion + (catch 'level-jump + (while oldl + (goto-char (car oldl)) + (if (looking-at "@\\(\\w+\\)") + (let* ((word (match-string 1)) + (levelmatch (assoc word texinfo-section-list)) + text begin tmp + ) + ;; Set begin to the right location + (setq begin (point)) + ;; Get out of here if there if we made it that far. + (if (and levelmatch (<= (car (cdr levelmatch)) level)) + (progn + (when newl + (semantic-texi-set-endpoint newl begin)) + (throw 'level-jump t))) + ;; Recombobulate + (if levelmatch + (let ((end (match-end 1))) + ;; Levels sometimes have a @node just in front. + ;; That node statement should be included in the space + ;; for this entry. + (save-excursion + (skip-chars-backward "\n \t") + (beginning-of-line) + (when (looking-at "@node\\>") + (setq begin (point)))) + ;; When there is a match, the descriptive text + ;; consists of the rest of the line. + (goto-char end) + (skip-chars-forward " \t") + (setq text (buffer-substring-no-properties + (point) + (progn (end-of-line) (point)))) + ;; Next, recurse into the body to find the end. + (setq tmp (semantic-texi-recursive-combobulate-list + (cdr oldl) (car (cdr levelmatch)))) + ;; Build a tag + (setq tag (semantic-texi-new-section-tag + text (car tmp) begin (point))) + ;; Before appending the newtag, update the previous tag + ;; if it is a section tag. + (when newl + (semantic-texi-set-endpoint newl begin)) + ;; Append new tag to our master list. + (setq newl (cons tag newl)) + ;; continue + (setq oldl (cdr tmp)) + ) + ;; No match means we have a def*, so get the name from + ;; it based on the type of thingy we found. + (setq levelmatch (assoc word semantic-texi-name-field-list) + tmp (or (cdr levelmatch) 1)) + (forward-sexp tmp) + (skip-chars-forward " \t") + (setq text (buffer-substring-no-properties + (point) + (progn (forward-sexp 1) (point)))) + ;; Seek the end of this definition + (goto-char begin) + (semantic-texi-forward-deffn) + (setq tag (semantic-texi-new-def-tag text begin (point)) + newl (cons tag newl)) + ;; continue + (setq oldl (cdr oldl))) + ) + (error "Problem finding section in semantic/texi parser")) + ;; (setq oldl (cdr oldl)) + ) + ;; When oldl runs out, force a new endpoint as point-max + (when (not oldl) + (semantic-texi-set-endpoint newl (point-max))) + )) + (cons (nreverse newl) oldl))) + +(defun semantic-texi-forward-deffn () + "Move forward over one deffn type definition. +The cursor should be on the @ sign." + (when (looking-at "@\\(\\w+\\)") + (let* ((type (match-string 1)) + (seek (concat "^@end\\s-+" (regexp-quote type)))) + (re-search-forward seek nil t)))) + +(define-mode-local-override semantic-tag-components + texinfo-mode (tag) + "Return components belonging to TAG." + (semantic-tag-get-attribute tag :members)) + + +;;; Overrides: Context Parsing +;; +;; How to treat texi as a language? +;; +(defvar semantic-texi-environment-regexp + (if (string-match texinfo-environment-regexp "@menu") + ;; Make sure our Emacs has menus in it. + texinfo-environment-regexp + ;; If no menus, then merge in the menu concept. + (when (string-match "cartouche" texinfo-environment-regexp) + (concat (substring texinfo-environment-regexp + 0 (match-beginning 0)) + "menu\\|" + (substring texinfo-environment-regexp + (match-beginning 0))))) + "Regular expression for matching texinfo enviroments. +uses `texinfo-environment-regexp', but makes sure that it +can handle the @menu environment.") + +(define-mode-local-override semantic-up-context texinfo-mode () + "Handle texinfo constructs which do not use parenthetical nesting." + (let ((done nil)) + (save-excursion + (let ((parenthetical (semantic-up-context-default)) + ) + (when (not parenthetical) + ;; We are in parenthises. Are they the types of parens + ;; belonging to a texinfo construct? + (forward-word -1) + (when (looking-at "@\\w+{") + (setq done (point)))))) + ;; If we are not in a parenthetical node, then find a block instead. + ;; Use the texinfo support to find block start/end constructs. + (save-excursion + (while (and (not done) + (re-search-backward semantic-texi-environment-regexp nil t)) + ;; For any hit, if we find an @end foo, then jump to the + ;; matching @foo. If it is not an end, then we win! + (if (not (looking-at "@end\\s-+\\(\\w+\\)")) + (setq done (point)) + ;; Skip over this block + (let ((env (match-string 1))) + (re-search-backward (concat "@" env)))) + )) + ;; All over, post what we find. + (if done + ;; We found something, so use it. + (progn (goto-char done) + nil) + t))) + +(define-mode-local-override semantic-beginning-of-context texinfo-mode (&optional point) + "Move to the beginning of the context surrounding POINT." + (if (semantic-up-context point) + ;; If we can't go up, we can't do this either. + t + ;; We moved, so now we need to skip into whatever this thing is. + (forward-word 1) ;; skip the command + (if (looking-at "\\s-*{") + ;; In a short command. Go in. + (down-list 1) + ;; An environment. Go to the next line. + (end-of-line) + (forward-char 1)) + nil)) + +(define-mode-local-override semantic-ctxt-current-class-list + texinfo-mode (&optional point) + "Determine the class of tags that can be used at POINT. +For texinfo, there two possibilities returned. +1) 'function - for a call to a texinfo function +2) 'word - indicates an english word. +It would be nice to know function arguments too, but not today." + (let ((sym (semantic-ctxt-current-symbol))) + (if (and sym (= (aref (car sym) 0) ?@)) + '(function) + '(word)))) + + +;;; Overrides : Formatting +;; +;; Various override to better format texi tags. +;; + +(define-mode-local-override semantic-format-tag-abbreviate + texinfo-mode (tag &optional parent color) + "Texinfo tags abbreviation." + (let ((class (semantic-tag-class tag)) + (name (semantic-format-tag-name tag parent color)) + ) + (cond ((eq class 'function) + (concat name "{ }")) + (t (semantic-format-tag-abbreviate-default tag parent color))) + )) + +(define-mode-local-override semantic-format-tag-prototype + texinfo-mode (tag &optional parent color) + "Texinfo tags abbreviation." + (semantic-format-tag-abbreviate tag parent color)) + + +;;; Texi Unique Features +;; +(defun semantic-tag-texi-section-text-bounds (tag) + "Get the bounds to the text of TAG. +The text bounds is the text belonging to this node excluding +the text of any child nodes, but including any defuns." + (let ((memb (semantic-tag-components tag))) + ;; Members.. if one is a section, check it out. + (while (and memb (not (semantic-tag-of-class-p (car memb) 'section))) + (setq memb (cdr memb))) + ;; No members? ... then a simple problem! + (if (not memb) + (semantic-tag-bounds tag) + ;; Our end is their beginning... + (list (semantic-tag-start tag) (semantic-tag-start (car memb)))))) + +(defun semantic-texi-current-environment (&optional point) + "Return as a string the type of the current environment. +Optional argument POINT is where to look for the environment." + (save-excursion + (when point (goto-char (point))) + (while (and (or (not (looking-at semantic-texi-environment-regexp)) + (looking-at "@end")) + (not (semantic-up-context))) + ) + (when (looking-at semantic-texi-environment-regexp) + (match-string 1)))) + + +;;; Analyzer +;; +(eval-when-compile + (require 'semantic/analyze)) + +(define-mode-local-override semantic-analyze-current-context + texinfo-mode (point) + "Analysis context makes no sense for texinfo. Return nil." + (let* ((prefixandbounds (semantic-ctxt-current-symbol-and-bounds (point))) + (prefix (car prefixandbounds)) + (bounds (nth 2 prefixandbounds)) + (prefixclass (semantic-ctxt-current-class-list)) + ) + (when prefix + (require 'semantic-analyze) + (semantic-analyze-context + "Context-for-texinfo" + :buffer (current-buffer) + :scope nil + :bounds bounds + :prefix prefix + :prefixtypes nil + :prefixclass prefixclass) + ) + )) + +(defvar semantic-texi-command-completion-list + (append (mapcar (lambda (a) (car a)) texinfo-section-list) + (condition-case nil + texinfo-environments + (error + ;; XEmacs doesn't use the above. Split up its regexp + (split-string texinfo-environment-regexp "\\\\|\\|\\^@\\\\(\\|\\\\)") + )) + ;; Is there a better list somewhere? Here are few + ;; of the top of my head. + "anchor" "asis" + "bullet" + "code" "copyright" + "defun" "deffn" "defoption" "defvar" "dfn" + "emph" "end" + "ifinfo" "iftex" "inforef" "item" "itemx" + "kdb" + "node" + "ref" + "set" "setfilename" "settitle" + "value" "var" + "xref" + ) + "List of commands that we might bother completing.") + +(define-mode-local-override semantic-analyze-possible-completions + texinfo-mode (context) + "List smart completions at point. +Since texinfo is not a programming language the default version is not +useful. Insted, look at the current symbol. If it is a command +do primitive texinfo built ins. If not, use ispell to lookup words +that start with that symbol." + (let ((prefix (car (oref context :prefix))) + ) + (cond ((member 'function (oref context :prefixclass)) + ;; Do completion for texinfo commands + (let* ((cmd (substring prefix 1)) + (lst (all-completions + cmd semantic-texi-command-completion-list))) + (mapcar (lambda (f) (semantic-tag (concat "@" f) 'function)) + lst)) + ) + ((member 'word (oref context :prefixclass)) + ;; Do completion for words via ispell. + (require 'ispell) + (let ((word-list (lookup-words prefix))) + (mapcar (lambda (f) (semantic-tag f 'word)) word-list)) + ) + (t nil)) + )) + + +;;; Parser Setup +;; +(defun semantic-default-texi-setup () + "Set up a buffer for parsing of Texinfo files." + ;; This will use our parser. + (semantic-install-function-overrides + '((parse-region . semantic-texi-parse-region) + (parse-changes . semantic-texi-parse-changes))) + (setq semantic-parser-name "TEXI" + ;; Setup a dummy parser table to enable parsing! + semantic--parse-table t + imenu-create-index-function 'semantic-create-imenu-index + semantic-command-separation-character "@" + semantic-type-relation-separator-character '(":") + semantic-symbol->name-assoc-list '((section . "Section") + (def . "Definition") + ) + semantic-imenu-expandable-tag-classes '(section) + semantic-imenu-bucketize-file nil + semantic-imenu-bucketize-type-members nil + senator-step-at-start-end-tag-classes '(section) + semantic-stickyfunc-sticky-classes '(section) + ) + (local-set-key [(f9)] 'semantic-texi-update-doc-from-texi) + ) + +(add-hook 'texinfo-mode-hook 'semantic-default-texi-setup) + + +;;; Special features of Texinfo tag streams +;; +;; This section provides specialized access into texinfo files. +;; Because texinfo files often directly refer to functions and programs +;; it is useful to access the texinfo file from the C code for document +;; maintainance. +(defun semantic-texi-associated-files (&optional buffer) + "Find texinfo files associated with BUFFER." + (save-excursion + (if buffer (set-buffer buffer)) + (cond ((and (fboundp 'ede-documentation-files) + ede-minor-mode (ede-current-project)) + ;; When EDE is active, ask it. + (ede-documentation-files) + ) + ((and (featurep 'semanticdb) (semanticdb-minor-mode-p)) + ;; See what texinfo files we have loaded in the database + (let ((tabs (semanticdb-get-database-tables + semanticdb-current-database)) + (r nil)) + (while tabs + (if (eq (oref (car tabs) major-mode) 'texinfo-mode) + (setq r (cons (oref (car tabs) file) r))) + (setq tabs (cdr tabs))) + r)) + (t + (directory-files default-directory nil "\\.texi$")) + ))) + +;; Turns out this might not be useful. +;; Delete later if that is true. +(defun semantic-texi-find-documentation (name &optional type) + "Find the function or variable NAME of TYPE in the texinfo source. +NAME is a string representing some functional symbol. +TYPE is a string, such as \"variable\" or \"Command\" used to find +the correct definition in case NAME qualifies as several things. +When this function exists, POINT is at the definition. +If the doc was not found, an error is thrown. +Note: TYPE not yet implemented." + (let ((f (semantic-texi-associated-files)) + stream match) + (while (and f (not match)) + (unless stream + (with-current-buffer (find-file-noselect (car f)) + (setq stream (semantic-fetch-tags)))) + (setq match (semantic-find-first-tag-by-name name stream)) + (when match + (set-buffer (semantic-tag-buffer match)) + (goto-char (semantic-tag-start match))) + (setq f (cdr f))))) + +(defun semantic-texi-update-doc-from-texi (&optional tag) + "Update the documentation in the texinfo deffn class tag TAG. +The current buffer must be a texinfo file containing TAG. +If TAG is nil, determine a tag based on the current position." + (interactive) + (unless (or (featurep 'semanticdb) (semanticdb-minor-mode-p)) + (error "Texinfo updating only works when `semanticdb' is being used")) + (semantic-fetch-tags) + (unless tag + (beginning-of-line) + (setq tag (semantic-current-tag))) + (unless (semantic-tag-of-class-p tag 'def) + (error "Only deffns (or defun or defvar) can be updated")) + (let* ((name (semantic-tag-name tag)) + (tags (semanticdb-strip-find-results + (semanticdb-with-match-any-mode + (semanticdb-brute-deep-find-tags-by-name name)) + 'name)) + (docstring nil) + (docstringproto nil) + (docstringvar nil) + (doctag nil) + (doctagproto nil) + (doctagvar nil) + ) + (save-excursion + (while (and tags (not docstring)) + (let ((sourcetag (car tags))) + ;; There could be more than one! Come up with a better + ;; solution someday. + (when (semantic-tag-buffer sourcetag) + (set-buffer (semantic-tag-buffer sourcetag)) + (unless (eq major-mode 'texinfo-mode) + (cond ((semantic-tag-get-attribute sourcetag :prototype-flag) + ;; If we found a match with doc that is a prototype, then store + ;; that, but don't exit till we find the real deal. + (setq docstringproto (semantic-documentation-for-tag sourcetag) + doctagproto sourcetag)) + ((eq (semantic-tag-class sourcetag) 'variable) + (setq docstringvar (semantic-documentation-for-tag sourcetag) + doctagvar sourcetag)) + ((semantic-tag-get-attribute sourcetag :override-function-flag) + nil) + (t + (setq docstring (semantic-documentation-for-tag sourcetag)))) + (setq doctag (if docstring sourcetag nil)))) + (setq tags (cdr tags))))) + ;; If we found a prototype of the function that has some doc, but not the + ;; actual function, lets make due with that. + (if (not docstring) + (cond ((stringp docstringvar) + (setq docstring docstringvar + doctag doctagvar)) + ((stringp docstringproto) + (setq docstring docstringproto + doctag doctagproto)))) + ;; Test for doc string + (unless docstring + (error "Could not find documentation for %s" (semantic-tag-name tag))) + ;; If we have a string, do the replacement. + (delete-region (semantic-tag-start tag) + (semantic-tag-end tag)) + ;; Use useful functions from the docaument library. + (require 'document) + (document-insert-texinfo doctag (semantic-tag-buffer doctag)) + )) + +(defun semantic-texi-update-doc-from-source (&optional tag) + "Update the documentation for the source TAG. +The current buffer must be a non-texinfo source file containing TAG. +If TAG is nil, determine the tag based on the current position. +The current buffer must include TAG." + (interactive) + (when (eq major-mode 'texinfo-mode) + (error "Not a source file")) + (semantic-fetch-tags) + (unless tag + (setq tag (semantic-current-tag))) + (unless (semantic-documentation-for-tag tag) + (error "Cannot find interesting documentation to use for %s" + (semantic-tag-name tag))) + (let* ((name (semantic-tag-name tag)) + (texi (semantic-texi-associated-files)) + (doctag nil) + (docbuff nil)) + (while (and texi (not doctag)) + (set-buffer (find-file-noselect (car texi))) + (setq doctag (car (semantic-deep-find-tags-by-name + name (semantic-fetch-tags))) + docbuff (if doctag (current-buffer) nil)) + (setq texi (cdr texi))) + (unless doctag + (error "Tag %s is not yet documented. Use the `document' command" + name)) + ;; Ok, we should have everything we need. Do the deed. + (if (get-buffer-window docbuff) + (set-buffer docbuff) + (switch-to-buffer docbuff)) + (goto-char (semantic-tag-start doctag)) + (delete-region (semantic-tag-start doctag) + (semantic-tag-end doctag)) + ;; Use useful functions from the document library. + (require 'document) + (document-insert-texinfo tag (semantic-tag-buffer tag)) + )) + +(defun semantic-texi-update-doc (&optional tag) + "Update the documentation for TAG. +If the current buffer is a texinfo file, then find the source doc, and +update it. If the current buffer is a source file, then get the +documentation for this item, find the existing doc in the associated +manual, and update that." + (interactive) + (cond ((eq major-mode 'texinfo-mode) + (semantic-texi-update-doc-from-texi tag)) + (t + (semantic-texi-update-doc-from-source tag)))) + +(defun semantic-texi-goto-source (&optional tag) + "Jump to the source for the definition in the texinfo file TAG. +If TAG is nil, it is derived from the deffn under POINT." + (interactive) + (unless (or (featurep 'semanticdb) (semanticdb-minor-mode-p)) + (error "Texinfo updating only works when `semanticdb' is being used")) + (semantic-fetch-tags) + (unless tag + (beginning-of-line) + (setq tag (semantic-current-tag))) + (unless (semantic-tag-of-class-p tag 'def) + (error "Only deffns (or defun or defvar) can be updated")) + (let* ((name (semantic-tag-name tag)) + (tags (semanticdb-fast-strip-find-results + (semanticdb-with-match-any-mode + (semanticdb-brute-deep-find-tags-by-name name nil 'name)) + )) + + (done nil) + ) + (save-excursion + (while (and tags (not done)) + (set-buffer (semantic-tag-buffer (car tags))) + (unless (eq major-mode 'texinfo-mode) + (switch-to-buffer (semantic-tag-buffer (car tags))) + (goto-char (semantic-tag-start (car tags))) + (setq done t)) + (setq tags (cdr tags))) + (if (not done) + (error "Could not find tag for %s" (semantic-tag-name tag))) + ))) + +(provide 'semantic/texi) + +;;; semantic-texi.el ends here