--- /dev/null
+;;; 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))
+
+\f
+;;; 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
+;;; 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
+ ))
+
+\f
+;;; 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))))
+
+\f
+;;; 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
+ ))
+
+\f
+;;; 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))
+
+\f
+;;; ------------------------------------------------------------
+;;; 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)
+ ))
+
+\f
+;;; ------------------------------------------------------------
+;;; 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))))
+
+
+\f
+;;; ------------------------------------------------------------
+;;; 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)))))
+
+\f
+;;; ------------------------------------------------------------
+;;; 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)))
+ )))
+
+\f
+;;; 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>
+
+\f
+;;; 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)))
+ )))
+
+\f
+;;; ------------------------------------------------------------
+;;; 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)
+ ))
+
+\f
+;;; ------------------------------------------------------------
+;;; 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
+;;; 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)
+ ))
+\f
+;;; 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
+;;; 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
+;;; 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))
+
+\f
+;;; 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)
+
+\f
+;;; 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))
+ )))
+
+\f
+;;; 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)))
+ )
+
+\f
+;;; 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))
+ ))
+
+\f
+;;; 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)
+
+\f
+;;; 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)
+\f
+;;; 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)))
+ ))))
+
+\f
+;;; 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
#'(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)))
\f
;;; Type table handling.
;;
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'."
;; 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
+;;; 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))
+
+\f
+;;; 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))))
+
+\f
+;;; 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))
+
+\f
+;;; 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))))
+
+\f
+;;; 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))
+ ))
+
+\f
+;;; 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)
+
+\f
+;;; 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
HCoop / bpt / emacs.git / commitdiff