From: Chong Yidong Date: Sat, 29 Aug 2009 19:00:35 +0000 (+0000) Subject: cedet/semantic/analyze.el, cedet/semantic/complete.el, X-Git-Tag: emacs-pretest-23.1.90~1091^2~101 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=9573e58b233ac4210a2801b1263f39843d4e48a0;p=emacs.git cedet/semantic/analyze.el, cedet/semantic/complete.el, cedet/semantic/edit.el, cedet/semantic/html.el, cedet/semantic/idle.el, cedet/semantic/texi.el: New files. cedet/semantic/lex.el: Move defsubsts to front of file to avoid compiler error. --- diff --git a/lisp/cedet/semantic/analyze.el b/lisp/cedet/semantic/analyze.el new file mode 100644 index 00000000000..7c47ba0877c --- /dev/null +++ b/lisp/cedet/semantic/analyze.el @@ -0,0 +1,769 @@ +;;; 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 + +;; 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 . + +;;; Commentary: +;; +;; Semantic, as a tool, provides a nice list of searchable tags. +;; That information can provide some very accurate answers if the current +;; context of a position is known. +;; +;; Semantic-ctxt provides ways of analyzing, and manipulating the +;; semantic context of a language in code. +;; +;; This library provides routines for finding intelligent answers to +;; tough problems, such as if an argument to a function has the correct +;; return type, or all possible tags that fit in a given local context. +;; + +;;; Vocabulary: +;; +;; Here are some words used to describe different things in the analyzer: +;; +;; tag - A single entity +;; prefix - The beginning of a symbol, usually used to look up something +;; incomplete. +;; type - The name of a datatype in the langauge. +;; metatype - If a type is named in a declaration like: +;; struct moose somevariable; +;; that name "moose" can be turned into a concrete type. +;; tag sequence - In C code, a list of dereferences, such as: +;; this.that.theother(); +;; parent - For a datatype in an OO language, another datatype +;; inherited from. This excludes interfaces. +;; scope - A list of tags that can be dereferenced that cannot +;; be found from the global namespace. +;; scopetypes - A list of tags which are datatype that contain +;; the scope. The scopetypes need to have the scope extracted +;; in a way that honors the type of inheritance. +;; nest/nested - When one tag is contained entirely in another. +;; +;; context - A semantic datatype representing a point in a buffer. +;; +;; constriant - If a context specifies a specific datatype is needed, +;; that is a constraint. +;; constants - Some datatypes define elements of themselves as a +;; constant. These need to be returned as there would be no +;; other possible completions. +;; +(require 'eieio) +;; (require 'inversion) +;; (eval-and-compile +;; (inversion-require 'eieio "1.0")) +(require 'semantic) +(require 'semantic/format) +(require 'semantic/ctxt) +(require 'semantic/sort) +(eval-when-compile (require 'semantic/db) + (require 'semantic/db-find)) + +(require 'semantic/scope) +(require 'semantic/analyze/fcn) + +;;; Code: +(defvar semantic-analyze-error-stack nil + "Collection of any errors thrown during analysis.") + +(defun semantic-analyze-push-error (err) + "Push the error in ERR-DATA onto the error stack. +Argument ERR" + (push err semantic-analyze-error-stack)) + +;;; Analysis Classes +;; +;; These classes represent what a context is. Different types +;; of contexts provide differing amounts of information to help +;; provide completions. +;; +(defclass semantic-analyze-context () + ((bounds :initarg :bounds + :type list + :documentation "The bounds of this context. +Usually bound to the dimension of a single symbol or command.") + (prefix :initarg :prefix + :type list + :documentation "List of tags defining local text. +This can be nil, or a list where the last element can be a string +representing text that may be incomplete. Preceeding elements +must be semantic tags representing variables or functions +called in a dereference sequence.") + (prefixclass :initarg :prefixclass + :type list + :documentation "Tag classes expected at this context. +These are clases for tags, such as 'function, or 'variable.") + (prefixtypes :initarg :prefixtypes + :type list + :documentation "List of tags defining types for :prefix. +This list is one shorter than :prefix. Each element is a semantic +tag representing a type matching the semantic tag in the same +position in PREFIX.") + (scope :initarg :scope + :type (or null semantic-scope-cache) + :documentation "List of tags available in scopetype. +See `semantic-analyze-scoped-tags' for details.") + (buffer :initarg :buffer + :type buffer + :documentation "The buffer this context is derived from.") + (errors :initarg :errors + :documentation "Any errors thrown an caught during analysis.") + ) + "Base analysis data for a any context.") + +(defclass semantic-analyze-context-assignment (semantic-analyze-context) + ((assignee :initarg :assignee + :type list + :documentation "A sequence of tags for an assignee. +This is a variable into which some value is being placed. The last +item in the list is the variable accepting the value. Earlier +tags represent the variables being derefernece to get to the +assignee.")) + "Analysis class for a value in an assignment.") + +(defclass semantic-analyze-context-functionarg (semantic-analyze-context) + ((function :initarg :function + :type list + :documentation "A sequence of tags for a function. +This is a function being called. The cursor will be in the position +of an argument. +The last tag in :function is the function being called. Earlier +tags represent the variables being dereferenced to get to the +function.") + (index :initarg :index + :type integer + :documentation "The index of the argument for this context. +If a function takes 4 arguments, this value should be bound to +the values 1 through 4.") + (argument :initarg :argument + :type list + :documentation "A sequence of tags for the :index argument. +The argument can accept a value of some type, and this contains the +tag for that definition. It should be a tag, but might +be just a string in some circumstances.") + ) + "Analysis class for a value as a function argument.") + +(defclass semantic-analyze-context-return (semantic-analyze-context) + () ; No extra data. + "Analysis class for return data. +Return data methods identify the requred type by the return value +of the parent function.") + +;;; METHODS +;; +;; Simple methods against the context classes. +;; +(defmethod semantic-analyze-type-constraint + ((context semantic-analyze-context) &optional desired-type) + "Return a type constraint for completing :prefix in CONTEXT. +Optional argument DESIRED-TYPE may be a non-type tag to analyze." + (when (semantic-tag-p desired-type) + ;; Convert the desired type if needed. + (if (not (eq (semantic-tag-class desired-type) 'type)) + (setq desired-type (semantic-tag-type desired-type))) + ;; Protect against plain strings + (cond ((stringp desired-type) + (setq desired-type (list desired-type 'type))) + ((and (stringp (car desired-type)) + (not (semantic-tag-p desired-type))) + (setq desired-type (list (car desired-type) 'type))) + ((semantic-tag-p desired-type) + ;; We have a tag of some sort. Yay! + nil) + (t (setq desired-type nil)) + ) + desired-type)) + +(defmethod semantic-analyze-type-constraint + ((context semantic-analyze-context-functionarg)) + "Return a type constraint for completing :prefix in CONTEXT." + (call-next-method context (car (oref context argument)))) + +(defmethod semantic-analyze-type-constraint + ((context semantic-analyze-context-assignment)) + "Return a type constraint for completing :prefix in CONTEXT." + (call-next-method context (car (reverse (oref context assignee))))) + +(defmethod semantic-analyze-interesting-tag + ((context semantic-analyze-context)) + "Return a tag from CONTEXT that would be most interesting to a user." + (let ((prefix (reverse (oref context :prefix)))) + ;; Go back through the prefix until we find a tag we can return. + (while (and prefix (not (semantic-tag-p (car prefix)))) + (setq prefix (cdr prefix))) + ;; Return the found tag, or nil. + (car prefix))) + +(defmethod semantic-analyze-interesting-tag + ((context semantic-analyze-context-functionarg)) + "Try the base, and if that fails, return what we are assigning into." + (or (call-next-method) (car-safe (oref context :function)))) + +(defmethod semantic-analyze-interesting-tag + ((context semantic-analyze-context-assignment)) + "Try the base, and if that fails, return what we are assigning into." + (or (call-next-method) (car-safe (oref context :assignee)))) + +;;; ANALYSIS +;; +;; Start out with routines that will calculate useful parts of +;; the general analyzer function. These could be used directly +;; by an application that doesn't need to calculate the full +;; context. + +(define-overloadable-function semantic-analyze-find-tag-sequence (sequence &optional + scope typereturn throwsym) + "Attempt to find all tags in SEQUENCE. +Optional argument LOCALVAR is the list of local variables to use when +finding the details on the first element of SEQUENCE in case +it is not found in the global set of tables. +Optional argument SCOPE are additional terminals to search which are currently +scoped. These are not local variables, but symbols available in a structure +which doesn't need to be dereferneced. +Optional argument TYPERETURN is a symbol in which the types of all found +will be stored. If nil, that data is thrown away. +Optional argument THROWSYM specifies a symbol the throw on non-recoverable error.") + +(defun semantic-analyze-find-tag-sequence-default (sequence &optional + scope typereturn + throwsym) + "Attempt to find all tags in SEQUENCE. +SCOPE are extra tags which are in scope. +TYPERETURN is a symbol in which to place a list of tag classes that +are found in SEQUENCE. +Optional argument THROWSYM specifies a symbol the throw on non-recoverable error." + (let ((s sequence) ; copy of the sequence + (tmp nil) ; tmp find variable + (tag nil) ; tag return list + (tagtype nil) ; tag types return list + (fname nil) + (miniscope (clone scope)) + ) + ;; First order check. Is this wholely contained in the typecache? + (setq tmp (semanticdb-typecache-find sequence)) + + (if tmp + (progn + ;; We are effectively done... + (setq s nil) + (setq tag (list tmp))) + + ;; For the first entry, it better be a variable, but it might + ;; be in the local context too. + ;; NOTE: Don't forget c++ namespace foo::bar. + (setq tmp (or + ;; Is this tag within our scope. Scopes can sometimes + ;; shadow other things, so it goes first. + (and scope (semantic-scope-find (car s) nil scope)) + ;; Find the tag out there... somewhere, but not in scope + (semantic-analyze-find-tag (car s)) + )) + + (if (and (listp tmp) (semantic-tag-p (car tmp))) + (setq tmp (semantic-analyze-select-best-tag tmp))) + (if (not (semantic-tag-p tmp)) + (if throwsym + (throw throwsym "Cannot find definition") + (error "Cannot find definition for \"%s\"" (car s)))) + (setq s (cdr s)) + (setq tag (cons tmp tag)) ; tag is nil here... + (setq fname (semantic-tag-file-name tmp)) + ) + + ;; For the middle entries + (while s + ;; Using the tag found in TMP, lets find the tag + ;; representing the full typeographic information of its + ;; type, and use that to determine the search context for + ;; (car s) + (let* ((tmptype + ;; In some cases the found TMP is a type, + ;; and we can use it directly. + (cond ((semantic-tag-of-class-p tmp 'type) + ;; update the miniscope when we need to analyze types directly. + (let ((rawscope + (apply 'append + (mapcar 'semantic-tag-type-members + tagtype)))) + (oset miniscope fullscope rawscope)) + ;; Now analayze the type to remove metatypes. + (or (semantic-analyze-type tmp miniscope) + tmp)) + (t + (semantic-analyze-tag-type tmp scope)))) + (typefile + (when tmptype + (semantic-tag-file-name tmptype))) + (slots nil)) + + ;; Get the children + (setq slots (semantic-analyze-scoped-type-parts tmptype scope)) + + ;; find (car s) in the list o slots + (setq tmp (semantic-find-tags-by-name (car s) slots)) + + ;; If we have lots + (if (and (listp tmp) (semantic-tag-p (car tmp))) + (setq tmp (semantic-analyze-select-best-tag tmp))) + + ;; Make sure we have a tag. + (if (not (semantic-tag-p tmp)) + (if (cdr s) + ;; In the middle, we need to keep seeking our types out. + (error "Cannot find definition for \"%s\"" (car s)) + ;; Else, it's ok to end with a non-tag + (setq tmp (car s)))) + + (setq fname (or typefile fname)) + (when (and fname (semantic-tag-p tmp) + (not (semantic-tag-in-buffer-p tmp))) + (semantic--tag-put-property tmp :filename fname)) + (setq tag (cons tmp tag)) + (setq tagtype (cons tmptype tagtype)) + ) + (setq s (cdr s))) + + (if typereturn (set typereturn (nreverse tagtype))) + ;; Return the mess + (nreverse tag))) + +(defun semantic-analyze-find-tag (name &optional tagclass scope) + "Return the first tag found with NAME or nil if not found. +Optional argument TAGCLASS specifies the class of tag to return, such +as 'function or 'variable. +Optional argument SCOPE specifies a scope object which has +additional tags which are in SCOPE and do not need prefixing to +find. + +This is a wrapper on top of semanticdb, semanticdb-typecache, +semantic-scope, and semantic search functions. Almost all +searches use the same arguments." + (let ((namelst (if (consp name) name ;; test if pre-split. + (semantic-analyze-split-name name)))) + (cond + ;; If the splitter gives us a list, use the sequence finder + ;; to get the list. Since this routine is expected to return + ;; only one tag, return the LAST tag found from the sequence + ;; which is supposedly the nested reference. + ;; + ;; Of note, the SEQUENCE function below calls this function + ;; (recursively now) so the names that we get from the above + ;; fcn better not, in turn, be splittable. + ((listp namelst) + ;; If we had a split, then this is likely a c++ style namespace::name sequence, + ;; so take a short-cut through the typecache. + (or (semanticdb-typecache-find namelst) + ;; Ok, not there, try the usual... + (let ((seq (semantic-analyze-find-tag-sequence + namelst scope nil))) + (semantic-analyze-select-best-tag seq tagclass) + ))) + ;; If NAME is solo, then do our searches for it here. + ((stringp namelst) + (let ((retlist (and scope (semantic-scope-find name tagclass scope)))) + (if retlist + (semantic-analyze-select-best-tag + retlist tagclass) + (if (eq tagclass 'type) + (semanticdb-typecache-find name) + ;; Search in the typecache. First entries in a sequence are + ;; often there. + (setq retlist (semanticdb-typecache-find name)) + (if retlist + retlist + (semantic-analyze-select-best-tag + (semanticdb-strip-find-results + (semanticdb-find-tags-by-name name) + 'name) + tagclass) + ))))) + ))) + +;;; SHORT ANALYSIS +;; +;; Create a mini-analysis of just the symbol under point. +;; +(define-overloadable-function semantic-analyze-current-symbol + (analyzehookfcn &optional position) + "Call ANALYZEHOOKFCN after analyzing the symbol under POSITION. +The ANALYZEHOOKFCN is called with the current symbol bounds, and the +analyzed prefix. It should take the arguments (START END PREFIX). +The ANALYZEHOOKFCN is only called if some sort of prefix with bounds was +found under POSITION. + +The results of ANALYZEHOOKFCN is returned, or nil if there was nothing to +call it with. + +For regular analysis, you should call `semantic-analyze-current-context' +to calculate the context information. The purpose for this function is +to provide a large number of non-cached analysis for filtering symbols." + ;; Only do this in a Semantic enabled buffer. + (when (not (semantic-active-p)) + (error "Cannot analyze buffers not supported by Semantic.")) + ;; Always refresh out tags in a safe way before doing the + ;; context. + (semantic-refresh-tags-safe) + ;; Do the rest of the analysis. + (save-match-data + (save-excursion + (:override))) + ) + +(defun semantic-analyze-current-symbol-default (analyzehookfcn position) + "Call ANALYZEHOOKFCN on the analyzed symbol at POSITION." + (let* ((semantic-analyze-error-stack nil) + (LLstart (current-time)) + (prefixandbounds (semantic-ctxt-current-symbol-and-bounds (or position (point)))) + (prefix (car prefixandbounds)) + (bounds (nth 2 prefixandbounds)) + (scope (semantic-calculate-scope position)) + (end nil) + ) + ;; Only do work if we have bounds (meaning a prefix to complete) + (when bounds + + (if debug-on-error + (catch 'unfindable + ;; If debug on error is on, allow debugging in this fcn. + (setq prefix (semantic-analyze-find-tag-sequence + prefix scope 'prefixtypes 'unfindable))) + ;; Debug on error is off. Capture errors and move on + (condition-case err + ;; NOTE: This line is duplicated in + ;; semantic-analyzer-debug-global-symbol + ;; You will need to update both places. + (setq prefix (semantic-analyze-find-tag-sequence + prefix scope 'prefixtypes)) + (error (semantic-analyze-push-error err)))) + + (setq end (current-time)) + ;;(message "Analysis took %.2f sec" (semantic-elapsed-time LLstart end)) + + ) + (when prefix + (prog1 + (funcall analyzehookfcn (car bounds) (cdr bounds) prefix) + ;;(setq end (current-time)) + ;;(message "hookfcn took %.5f sec" (semantic-elapsed-time LLstart end)) + ) + + ))) + +;;; MAIN ANALYSIS +;; +;; Create a full-up context analysis. +;; +(define-overloadable-function semantic-analyze-current-context (&optional position) + "Analyze the current context at optional POSITION. +If called interactively, display interesting information about POSITION +in a separate buffer. +Returns an object based on symbol `semantic-analyze-context'. + +This function can be overriden with the symbol `analyze-context'. +When overriding this function, your override will be called while +cursor is at POSITION. In addition, your function will not be called +if a cached copy of the return object is found." + (interactive "d") + ;; Only do this in a Semantic enabled buffer. + (when (not (semantic-active-p)) + (error "Cannot analyze buffers not supported by Semantic.")) + ;; Always refresh out tags in a safe way before doing the + ;; context. + (semantic-refresh-tags-safe) + ;; Do the rest of the analysis. + (if (not position) (setq position (point))) + (save-excursion + (goto-char position) + (let* ((answer (semantic-get-cache-data 'current-context))) + (with-syntax-table semantic-lex-syntax-table + (when (not answer) + (setq answer (:override)) + (when (and answer (oref answer bounds)) + (with-slots (bounds) answer + (semantic-cache-data-to-buffer (current-buffer) + (car bounds) + (cdr bounds) + answer + 'current-context + 'exit-cache-zone))) + ;; Check for interactivity + (when (interactive-p) + (if answer + (semantic-analyze-pop-to-context answer) + (message "No Context.")) + )) + + answer)))) + +(defun semantic-analyze-current-context-default (position) + "Analyze the current context at POSITION. +Returns an object based on symbol `semantic-analyze-context'." + (let* ((semantic-analyze-error-stack nil) + (context-return nil) + (prefixandbounds (semantic-ctxt-current-symbol-and-bounds (or position (point)))) + (prefix (car prefixandbounds)) + (bounds (nth 2 prefixandbounds)) + ;; @todo - vv too early to really know this answer! vv + (prefixclass (semantic-ctxt-current-class-list)) + (prefixtypes nil) + (scope (semantic-calculate-scope position)) + (function nil) + (fntag nil) + arg fntagend argtag + assign asstag + ) + + ;; Pattern for Analysis: + ;; + ;; Step 1: Calculate DataTypes in Scope: + ;; + ;; a) Calculate the scope (above) + ;; + ;; Step 2: Parse context + ;; + ;; a) Identify function being called, or variable assignment, + ;; and find source tags for those references + ;; b) Identify the prefix (text cursor is on) and find the source + ;; tags for those references. + ;; + ;; Step 3: Assemble an object + ;; + + ;; Step 2 a: + + (setq function (semantic-ctxt-current-function)) + + (when function + ;; Calculate the argument for the function if there is one. + (setq arg (semantic-ctxt-current-argument)) + + ;; Find a tag related to the function name. + (condition-case err + (setq fntag + (semantic-analyze-find-tag-sequence function scope)) + (error (semantic-analyze-push-error err))) + + ;; fntag can have the last entry as just a string, meaning we + ;; could not find the core datatype. In this case, the searches + ;; below will not work. + (when (stringp (car (last fntag))) + ;; Take a wild guess! + (setcar (last fntag) (semantic-tag (car (last fntag)) 'function)) + ) + + (when fntag + (let ((fcn (semantic-find-tags-by-class 'function fntag))) + (when (not fcn) + (let ((ty (semantic-find-tags-by-class 'type fntag))) + (when ty + ;; We might have a constructor with the same name as + ;; the found datatype. + (setq fcn (semantic-find-tags-by-name + (semantic-tag-name (car ty)) + (semantic-tag-type-members (car ty)))) + (if fcn + (let ((lp fcn)) + (while lp + (when (semantic-tag-get-attribute (car lp) + :constructor) + (setq fcn (cons (car lp) fcn))) + (setq lp (cdr lp)))) + ;; Give up, go old school + (setq fcn fntag)) + ))) + (setq fntagend (car (reverse fcn)) + argtag + (when (semantic-tag-p fntagend) + (nth (1- arg) (semantic-tag-function-arguments fntagend))) + fntag fcn)))) + + ;; Step 2 b: + + ;; Only do work if we have bounds (meaning a prefix to complete) + (when bounds + + (if debug-on-error + (catch 'unfindable + ;; If debug on error is on, allow debugging in this fcn. + (setq prefix (semantic-analyze-find-tag-sequence + prefix scope 'prefixtypes 'unfindable))) + ;; Debug on error is off. Capture errors and move on + (condition-case err + ;; NOTE: This line is duplicated in + ;; semantic-analyzer-debug-global-symbol + ;; You will need to update both places. + (setq prefix (semantic-analyze-find-tag-sequence + prefix scope 'prefixtypes)) + (error (semantic-analyze-push-error err)))) + ) + + ;; Step 3: + + (cond + (fntag + ;; If we found a tag for our function, we can go into + ;; functional context analysis mode, meaning we have a type + ;; for the argument. + (setq context-return + (semantic-analyze-context-functionarg + "functionargument" + :buffer (current-buffer) + :function fntag + :index arg + :argument (list argtag) + :scope scope + :prefix prefix + :prefixclass prefixclass + :bounds bounds + :prefixtypes prefixtypes + :errors semantic-analyze-error-stack))) + + ;; No function, try assignment + ((and (setq assign (semantic-ctxt-current-assignment)) + ;; We have some sort of an assignment + (condition-case err + (setq asstag (semantic-analyze-find-tag-sequence + assign scope)) + (error (semantic-analyze-push-error err) + nil))) + + (setq context-return + (semantic-analyze-context-assignment + "assignment" + :buffer (current-buffer) + :assignee asstag + :scope scope + :bounds bounds + :prefix prefix + :prefixclass prefixclass + :prefixtypes prefixtypes + :errors semantic-analyze-error-stack))) + + ;; TODO: Identify return value condition. + ;;((setq return .... what to do?) + ;; ...) + + (bounds + ;; Nothing in particular + (setq context-return + (semantic-analyze-context + "context" + :buffer (current-buffer) + :scope scope + :bounds bounds + :prefix prefix + :prefixclass prefixclass + :prefixtypes prefixtypes + :errors semantic-analyze-error-stack))) + + (t (setq context-return nil)) + ) + + ;; Return our context. + context-return)) + + +;;; DEBUG OUTPUT +;; +;; Friendly output of a context analysis. +;; +(defmethod semantic-analyze-pulse ((context semantic-analyze-context)) + "Pulse the region that CONTEXT affects." + (save-excursion + (set-buffer (oref context :buffer)) + (let ((bounds (oref context :bounds))) + (when bounds + (pulse-momentary-highlight-region (car bounds) (cdr bounds)))))) + +(defcustom semantic-analyze-summary-function 'semantic-format-tag-prototype + "*Function to use when creating items in Imenu. +Some useful functions are found in `semantic-format-tag-functions'." + :group 'semantic + :type semantic-format-tag-custom-list) + +(defun semantic-analyze-princ-sequence (sequence &optional prefix buff) + "Send the tag SEQUENCE to standard out. +Use PREFIX as a label. +Use BUFF as a source of override methods." + (while sequence + (princ prefix) + (cond + ((semantic-tag-p (car sequence)) + (princ (funcall semantic-analyze-summary-function + (car sequence)))) + ((stringp (car sequence)) + (princ "\"") + (princ (semantic--format-colorize-text (car sequence) 'variable)) + (princ "\"")) + (t + (princ (format "'%S" (car sequence))))) + (princ "\n") + (setq sequence (cdr sequence)) + (setq prefix (make-string (length prefix) ? )) + )) + +(defmethod semantic-analyze-show ((context semantic-analyze-context)) + "Insert CONTEXT into the current buffer in a nice way." + (semantic-analyze-princ-sequence (oref context prefix) "Prefix: " ) + (semantic-analyze-princ-sequence (oref context prefixclass) "Prefix Classes: ") + (semantic-analyze-princ-sequence (oref context prefixtypes) "Prefix Types: ") + (semantic-analyze-princ-sequence (oref context errors) "Encountered Errors: ") + (princ "--------\n") + ;(semantic-analyze-princ-sequence (oref context scopetypes) "Scope Types: ") + ;(semantic-analyze-princ-sequence (oref context scope) "Scope: ") + ;(semantic-analyze-princ-sequence (oref context localvariables) "LocalVars: ") + (when (oref context scope) + (semantic-analyze-show (oref context scope))) + ) + +(defmethod semantic-analyze-show ((context semantic-analyze-context-assignment)) + "Insert CONTEXT into the current buffer in a nice way." + (semantic-analyze-princ-sequence (oref context assignee) "Assignee: ") + (call-next-method)) + +(defmethod semantic-analyze-show ((context semantic-analyze-context-functionarg)) + "Insert CONTEXT into the current buffer in a nice way." + (semantic-analyze-princ-sequence (oref context function) "Function: ") + (princ "Argument Index: ") + (princ (oref context index)) + (princ "\n") + (semantic-analyze-princ-sequence (oref context argument) "Argument: ") + (call-next-method)) + +(defun semantic-analyze-pop-to-context (context) + "Display CONTEXT in a temporary buffer. +CONTEXT's content is described in `semantic-analyze-current-context'." + (semantic-analyze-pulse context) + (with-output-to-temp-buffer "*Semantic Context Analysis*" + (princ "Context Type: ") + (princ (object-name context)) + (princ "\n") + (princ "Bounds: ") + (princ (oref context bounds)) + (princ "\n") + (semantic-analyze-show context) + ) + (shrink-window-if-larger-than-buffer + (get-buffer-window "*Semantic Context Analysis*")) + ) + +(provide 'semantic/analyze) + +;;; semantic-analyze.el ends here diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el new file mode 100644 index 00000000000..d1367e30b7d --- /dev/null +++ b/lisp/cedet/semantic/complete.el @@ -0,0 +1,2128 @@ +;;; complete.el --- Routines for performing tag completion + +;;; Copyright (C) 2003, 2004, 2005, 2007, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; 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 . + +;;; Commentary: +;; +;; Completion of tags by name using tables of semantic generated tags. +;; +;; While it would be a simple matter of flattening all tag known +;; tables to perform completion across them using `all-completions', +;; or `try-completion', that process would be slow. In particular, +;; when a system database is included in the mix, the potential for a +;; ludicrous number of options becomes apparent. +;; +;; As such, dynamically searching across tables using a prefix, +;; regular expression, or other feature is needed to help find symbols +;; quickly without resorting to "show me every possible option now". +;; +;; In addition, some symbol names will appear in multiple locations. +;; If it is important to distiguish, then a way to provide a choice +;; over these locations is important as well. +;; +;; Beyond brute force offers for completion of plain strings, +;; using the smarts of semantic-analyze to provide reduced lists of +;; symbols, or fancy tabbing to zoom into files to show multiple hits +;; of the same name can be provided. +;; +;;; How it works: +;; +;; There are several parts of any completion engine. They are: +;; +;; A. Collection of possible hits +;; B. Typing or selecting an option +;; C. Displaying possible unique completions +;; D. Using the result +;; +;; Here, we will treat each section separately (excluding D) +;; They can then be strung together in user-visible commands to +;; fullfill specific needs. +;; +;; COLLECTORS: +;; +;; A collector is an object which represents the means by which tags +;; to complete on are collected. It's first job is to find all the +;; tags which are to be completed against. It can also rename +;; some tags if needed so long as `semantic-tag-clone' is used. +;; +;; Some collectors will gather all tags to complete against first +;; (for in buffer queries, or other small list situations). It may +;; choose to do a broad search on each completion request. Built in +;; functionality automatically focuses the cache in as the user types. +;; +;; A collector choosing to create and rename tags could choose a +;; plain name format, a postfix name such as method:class, or a +;; prefix name such as class.method. +;; +;; DISPLAYORS +;; +;; A displayor is in charge if showing the user interesting things +;; about available completions, and can optionally provide a focus. +;; The simplest display just lists all available names in a separate +;; window. It may even choose to show short names when there are +;; many to choose from, or long names when there are fewer. +;; +;; A complex displayor could opt to help the user 'focus' on some +;; range. For example, if 4 tags all have the same name, subsequent +;; calls to the displayor may opt to show each tag one at a time in +;; the buffer. When the user likes one, selection would cause the +;; 'focus' item to be selected. +;; +;; CACHE FORMAT +;; +;; The format of the tag lists used to perform the completions are in +;; semanticdb "find" format, like this: +;; +;; ( ( DBTABLE1 TAG1 TAG2 ...) +;; ( DBTABLE2 TAG1 TAG2 ...) +;; ... ) +;; +;; INLINE vs MINIBUFFER +;; +;; Two major ways completion is used in Emacs is either through a +;; minibuffer query, or via completion in a normal editing buffer, +;; encompassing some small range of characters. +;; +;; Structure for both types of completion are provided here. +;; `semantic-complete-read-tag-engine' will use the minibuffer. +;; `semantic-complete-inline-tag-engine' will complete text in +;; a buffer. + +(require 'eieio) +(require 'semantic/tag) +(require 'semantic/find) +(require 'semantic/analyze) +(require 'semantic/format) +(require 'semantic/ctxt) +;; Keep semanticdb optional. +(eval-when-compile + (require 'semantic/db) + (require 'semantic/db-find)) + +(eval-when-compile + (condition-case nil + ;; Tooltip not available in older emacsen. + (require 'tooltip) + (error nil)) + ) + +;;; Code: + +;;; Compatibility +;; +(if (fboundp 'minibuffer-contents) + (eval-and-compile (defalias 'semantic-minibuffer-contents 'minibuffer-contents)) + (eval-and-compile (defalias 'semantic-minibuffer-contents 'buffer-string))) +(if (fboundp 'delete-minibuffer-contents) + (eval-and-compile (defalias 'semantic-delete-minibuffer-contents 'delete-minibuffer-contents)) + (eval-and-compile (defalias 'semantic-delete-minibuffer-contents 'erase-buffer))) + +(defvar semantic-complete-inline-overlay nil + "The overlay currently active while completing inline.") + +(defun semantic-completion-inline-active-p () + "Non-nil if inline completion is active." + (when (and semantic-complete-inline-overlay + (not (semantic-overlay-live-p semantic-complete-inline-overlay))) + (semantic-overlay-delete semantic-complete-inline-overlay) + (setq semantic-complete-inline-overlay nil)) + semantic-complete-inline-overlay) + +;;; ------------------------------------------------------------ +;;; MINIBUFFER or INLINE utils +;; +(defun semantic-completion-text () + "Return the text that is currently in the completion buffer. +For a minibuffer prompt, this is the minibuffer text. +For inline completion, this is the text wrapped in the inline completion +overlay." + (if semantic-complete-inline-overlay + (semantic-complete-inline-text) + (semantic-minibuffer-contents))) + +(defun semantic-completion-delete-text () + "Delete the text that is actively being completed. +Presumably if you call this you will insert something new there." + (if semantic-complete-inline-overlay + (semantic-complete-inline-delete-text) + (semantic-delete-minibuffer-contents))) + +(defun semantic-completion-message (fmt &rest args) + "Display the string FMT formatted with ARGS at the end of the minibuffer." + (if semantic-complete-inline-overlay + (apply 'message fmt args) + (message (concat (buffer-string) (apply 'format fmt args))))) + +;;; ------------------------------------------------------------ +;;; MINIBUFFER: Option Selection harnesses +;; +(defvar semantic-completion-collector-engine nil + "The tag collector for the current completion operation. +Value should be an object of a subclass of +`semantic-completion-engine-abstract'.") + +(defvar semantic-completion-display-engine nil + "The tag display engine for the current completion operation. +Value should be a ... what?") + +(defvar semantic-complete-key-map + (let ((km (make-sparse-keymap))) + (define-key km " " 'semantic-complete-complete-space) + (define-key km "\t" 'semantic-complete-complete-tab) + (define-key km "\C-m" 'semantic-complete-done) + (define-key km "\C-g" 'abort-recursive-edit) + (define-key km "\M-n" 'next-history-element) + (define-key km "\M-p" 'previous-history-element) + (define-key km "\C-n" 'next-history-element) + (define-key km "\C-p" 'previous-history-element) + ;; Add history navigation + km) + "Keymap used while completing across a list of tags.") + +(defvar semantic-completion-default-history nil + "Default history variable for any unhistoried prompt. +Keeps STRINGS only in the history.") + + +(defun semantic-complete-read-tag-engine (collector displayor prompt + default-tag initial-input + history) + "Read a semantic tag, and return a tag for the selection. +Argument COLLECTOR is an object which can be used to to calculate +a list of possible hits. See `semantic-completion-collector-engine' +for details on COLLECTOR. +Argumeng DISPLAYOR is an object used to display a list of possible +completions for a given prefix. See`semantic-completion-display-engine' +for details on DISPLAYOR. +PROMPT is a string to prompt with. +DEFAULT-TAG is a semantic tag or string to use as the default value. +If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. +HISTORY is a symbol representing a variable to story the history in." + (let* ((semantic-completion-collector-engine collector) + (semantic-completion-display-engine displayor) + (semantic-complete-active-default nil) + (semantic-complete-current-matched-tag nil) + (default-as-tag (semantic-complete-default-to-tag default-tag)) + (default-as-string (when (semantic-tag-p default-as-tag) + (semantic-tag-name default-as-tag))) + ) + + (when default-as-string + ;; Add this to the prompt. + ;; + ;; I really want to add a lookup of the symbol in those + ;; tags available to the collector and only add it if it + ;; is available as a possibility, but I'm too lazy right + ;; now. + ;; + + ;; @todo - move from () to into the editable area + (if (string-match ":" prompt) + (setq prompt (concat + (substring prompt 0 (match-beginning 0)) + " (" default-as-string ")" + (substring prompt (match-beginning 0)))) + (setq prompt (concat prompt " (" default-as-string "): ")))) + ;; + ;; Perform the Completion + ;; + (unwind-protect + (read-from-minibuffer prompt + initial-input + semantic-complete-key-map + nil + (or history + 'semantic-completion-default-history) + default-tag) + (semantic-collector-cleanup semantic-completion-collector-engine) + (semantic-displayor-cleanup semantic-completion-display-engine) + ) + ;; + ;; Extract the tag from the completion machinery. + ;; + semantic-complete-current-matched-tag + )) + + +;;; Util for basic completion prompts +;; + +(defvar semantic-complete-active-default nil + "The current default tag calculated for this prompt.") + +(defun semantic-complete-default-to-tag (default) + "Convert a calculated or passed in DEFAULT into a tag." + (if (semantic-tag-p default) + ;; Just return what was passed in. + (setq semantic-complete-active-default default) + ;; If none was passed in, guess. + (if (null default) + (setq default (semantic-ctxt-current-thing))) + (if (null default) + ;; Do nothing + nil + ;; Turn default into something useful. + (let ((str + (cond + ;; Semantic-ctxt-current-symbol will return a list of + ;; strings. Technically, we should use the analyzer to + ;; fully extract what we need, but for now, just grab the + ;; first string + ((and (listp default) (stringp (car default))) + (car default)) + ((stringp default) + default) + ((symbolp default) + (symbol-name default)) + (t + (signal 'wrong-type-argument + (list default 'semantic-tag-p))))) + (tag nil)) + ;; Now that we have that symbol string, look it up using the active + ;; collector. If we get a match, use it. + (save-excursion + (semantic-collector-calculate-completions + semantic-completion-collector-engine + str nil)) + ;; Do we have the perfect match??? + (let ((ml (semantic-collector-current-exact-match + semantic-completion-collector-engine))) + (when ml + ;; We don't care about uniqueness. Just guess for convenience + (setq tag (semanticdb-find-result-nth-in-buffer ml 0)))) + ;; save it + (setq semantic-complete-active-default tag) + ;; Return it.. .whatever it may be + tag)))) + + +;;; Prompt Return Value +;; +;; Getting a return value out of this completion prompt is a bit +;; challenging. The read command returns the string typed in. +;; We need to convert this into a valid tag. We can exit the minibuffer +;; for different reasons. If we purposely exit, we must make sure +;; the focused tag is calculated... preferably once. +(defvar semantic-complete-current-matched-tag nil + "Variable used to pass the tags being matched to the prompt.") + +(defun semantic-complete-current-match () + "Calculate a match from the current completion environment. +Save this in our completion variable. Make sure that variable +is cleared if any other keypress is made. +Return value can be: + tag - a single tag that has been matched. + string - a message to show in the minibuffer." + ;; Query the environment for an active completion. + (let ((collector semantic-completion-collector-engine) + (displayor semantic-completion-display-engine) + (contents (semantic-completion-text)) + matchlist + answer) + (if (string= contents "") + ;; The user wants the defaults! + (setq answer semantic-complete-active-default) + ;; This forces a full calculation of completion on CR. + (save-excursion + (semantic-collector-calculate-completions collector contents nil)) + (semantic-complete-try-completion) + (cond + ;; Input match displayor focus entry + ((setq answer (semantic-displayor-current-focus displayor)) + ;; We have answer, continue + ) + ;; One match from the collector + ((setq matchlist (semantic-collector-current-exact-match collector)) + (if (= (semanticdb-find-result-length matchlist) 1) + (setq answer (semanticdb-find-result-nth-in-buffer matchlist 0)) + (if (semantic-displayor-focus-abstract-child-p displayor) + ;; For focusing displayors, we can claim this is + ;; not unique. Multiple focuses can choose the correct + ;; one. + (setq answer "Not Unique") + ;; If we don't have a focusing displayor, we need to do something + ;; graceful. First, see if all the matches have the same name. + (let ((allsame t) + (firstname (semantic-tag-name + (car + (semanticdb-find-result-nth matchlist 0))) + ) + (cnt 1) + (max (semanticdb-find-result-length matchlist))) + (while (and allsame (< cnt max)) + (if (not (string= + firstname + (semantic-tag-name + (car + (semanticdb-find-result-nth matchlist cnt))))) + (setq allsame nil)) + (setq cnt (1+ cnt)) + ) + ;; Now we know if they are all the same. If they are, just + ;; accept the first, otherwise complain. + (if allsame + (setq answer (semanticdb-find-result-nth-in-buffer + matchlist 0)) + (setq answer "Not Unique")) + )))) + ;; No match + (t + (setq answer "No Match"))) + ) + ;; Set it into our completion target. + (when (semantic-tag-p answer) + (setq semantic-complete-current-matched-tag answer) + ;; Make sure it is up to date by clearing it if the user dares + ;; to touch the keyboard. + (add-hook 'pre-command-hook + (lambda () (setq semantic-complete-current-matched-tag nil))) + ) + ;; Return it + answer + )) + + +;;; Keybindings +;; +;; Keys are bound to to perform completion using our mechanisms. +;; Do that work here. +(defun semantic-complete-done () + "Accept the current input." + (interactive) + (let ((ans (semantic-complete-current-match))) + (if (stringp ans) + (semantic-completion-message (concat " [" ans "]")) + (exit-minibuffer))) + ) + +(defun semantic-complete-complete-space () + "Complete the partial input in the minibuffer." + (interactive) + (semantic-complete-do-completion t)) + +(defun semantic-complete-complete-tab () + "Complete the partial input in the minibuffer as far as possible." + (interactive) + (semantic-complete-do-completion)) + +;;; Completion Functions +;; +;; Thees routines are functional entry points to performing completion. +;; +(defun semantic-complete-hack-word-boundaries (original new) + "Return a string to use for completion. +ORIGINAL is the text in the minibuffer. +NEW is the new text to insert into the minibuffer. +Within the difference bounds of ORIGINAL and NEW, shorten NEW +to the nearest word boundary, and return that." + (save-match-data + (let* ((diff (substring new (length original))) + (end (string-match "\\>" diff)) + (start (string-match "\\<" diff))) + (cond + ((and start (> start 0)) + ;; If start is greater than 0, include only the new + ;; white-space stuff + (concat original (substring diff 0 start))) + (end + (concat original (substring diff 0 end))) + (t new))))) + +(defun semantic-complete-try-completion (&optional partial) + "Try a completion for the current minibuffer. +If PARTIAL, do partial completion stopping at spaces." + (let ((comp (semantic-collector-try-completion + semantic-completion-collector-engine + (semantic-completion-text)))) + (cond + ((null comp) + (semantic-completion-message " [No Match]") + (ding) + ) + ((stringp comp) + (if (string= (semantic-completion-text) comp) + (when partial + ;; Minibuffer isn't changing AND the text is not unique. + ;; Test for partial completion over a word separator character. + ;; If there is one available, use that so that SPC can + ;; act like a SPC insert key. + (let ((newcomp (semantic-collector-current-whitespace-completion + semantic-completion-collector-engine))) + (when newcomp + (semantic-completion-delete-text) + (insert newcomp)) + )) + (when partial + (let ((orig (semantic-completion-text))) + ;; For partial completion, we stop and step over + ;; word boundaries. Use this nifty function to do + ;; that calculation for us. + (setq comp + (semantic-complete-hack-word-boundaries orig comp)))) + ;; Do the replacement. + (semantic-completion-delete-text) + (insert comp)) + ) + ((and (listp comp) (semantic-tag-p (car comp))) + (unless (string= (semantic-completion-text) + (semantic-tag-name (car comp))) + ;; A fully unique completion was available. + (semantic-completion-delete-text) + (insert (semantic-tag-name (car comp)))) + ;; The match is complete + (if (= (length comp) 1) + (semantic-completion-message " [Complete]") + (semantic-completion-message " [Complete, but not unique]")) + ) + (t nil)))) + +(defun semantic-complete-do-completion (&optional partial inline) + "Do a completion for the current minibuffer. +If PARTIAL, do partial completion stopping at spaces. +if INLINE, then completion is happening inline in a buffer." + (let* ((collector semantic-completion-collector-engine) + (displayor semantic-completion-display-engine) + (contents (semantic-completion-text)) + (ans nil)) + + (save-excursion + (semantic-collector-calculate-completions collector contents partial)) + (let* ((na (semantic-complete-next-action partial))) + (cond + ;; We're all done, but only from a very specific + ;; area of completion. + ((eq na 'done) + (semantic-completion-message " [Complete]") + (setq ans 'done)) + ;; Perform completion + ((or (eq na 'complete) + (eq na 'complete-whitespace)) + (semantic-complete-try-completion partial) + (setq ans 'complete)) + ;; We need to display the completions. + ;; Set the completions into the display engine + ((or (eq na 'display) (eq na 'displayend)) + (semantic-displayor-set-completions + displayor + (or + (and (not (eq na 'displayend)) + (semantic-collector-current-exact-match collector)) + (semantic-collector-all-completions collector contents)) + contents) + ;; Ask the displayor to display them. + (semantic-displayor-show-request displayor)) + ((eq na 'scroll) + (semantic-displayor-scroll-request displayor) + ) + ((eq na 'focus) + (semantic-displayor-focus-next displayor) + (semantic-displayor-focus-request displayor) + ) + ((eq na 'empty) + (semantic-completion-message " [No Match]")) + (t nil))) + ans)) + + +;;; ------------------------------------------------------------ +;;; INLINE: tag completion harness +;; +;; Unlike the minibuffer, there is no mode nor other traditional +;; means of reading user commands in completion mode. Instead +;; we use a pre-command-hook to inset in our commands, and to +;; push ourselves out of this mode on alternate keypresses. +(defvar semantic-complete-inline-map + (let ((km (make-sparse-keymap))) + (define-key km "\C-i" 'semantic-complete-inline-TAB) + (define-key km "\M-p" 'semantic-complete-inline-up) + (define-key km "\M-n" 'semantic-complete-inline-down) + (define-key km "\C-m" 'semantic-complete-inline-done) + (define-key km "\C-\M-c" 'semantic-complete-inline-exit) + (define-key km "\C-g" 'semantic-complete-inline-quit) + (define-key km "?" + (lambda () (interactive) + (describe-variable 'semantic-complete-inline-map))) + km) + "Keymap used while performing Semantic inline completion. +\\{semantic-complete-inline-map}") + +(defface semantic-complete-inline-face + '((((class color) (background dark)) + (:underline "yellow")) + (((class color) (background light)) + (:underline "brown"))) + "*Face used to show the region being completed inline. +The face is used in `semantic-complete-inline-tag-engine'." + :group 'semantic-faces) + +(defun semantic-complete-inline-text () + "Return the text that is being completed inline. +Similar to `minibuffer-contents' when completing in the minibuffer." + (let ((s (semantic-overlay-start semantic-complete-inline-overlay)) + (e (semantic-overlay-end semantic-complete-inline-overlay))) + (if (= s e) + "" + (buffer-substring-no-properties s e )))) + +(defun semantic-complete-inline-delete-text () + "Delete the text currently being completed in the current buffer." + (delete-region + (semantic-overlay-start semantic-complete-inline-overlay) + (semantic-overlay-end semantic-complete-inline-overlay))) + +(defun semantic-complete-inline-done () + "This completion thing is DONE, OR, insert a newline." + (interactive) + (let* ((displayor semantic-completion-display-engine) + (tag (semantic-displayor-current-focus displayor))) + (if tag + (let ((txt (semantic-completion-text))) + (insert (substring (semantic-tag-name tag) + (length txt))) + (semantic-complete-inline-exit)) + + ;; Get whatever binding RET usually has. + (let ((fcn + (condition-case nil + (lookup-key (current-active-maps) (this-command-keys)) + (error + ;; I don't know why, but for some reason the above + ;; throws an error sometimes. + (lookup-key (current-global-map) (this-command-keys)) + )))) + (when fcn + (funcall fcn))) + ))) + +(defun semantic-complete-inline-quit () + "Quit an inline edit." + (interactive) + (semantic-complete-inline-exit) + (keyboard-quit)) + +(defun semantic-complete-inline-exit () + "Exit inline completion mode." + (interactive) + ;; Remove this hook FIRST! + (remove-hook 'pre-command-hook 'semantic-complete-pre-command-hook) + + (condition-case nil + (progn + (when semantic-completion-collector-engine + (semantic-collector-cleanup semantic-completion-collector-engine)) + (when semantic-completion-display-engine + (semantic-displayor-cleanup semantic-completion-display-engine)) + + (when semantic-complete-inline-overlay + (let ((wc (semantic-overlay-get semantic-complete-inline-overlay + 'window-config-start)) + (buf (semantic-overlay-buffer semantic-complete-inline-overlay)) + ) + (semantic-overlay-delete semantic-complete-inline-overlay) + (setq semantic-complete-inline-overlay nil) + ;; DONT restore the window configuration if we just + ;; switched windows! + (when (eq buf (current-buffer)) + (set-window-configuration wc)) + )) + + (setq semantic-completion-collector-engine nil + semantic-completion-display-engine nil)) + (error nil)) + + ;; Remove this hook LAST!!! + ;; This will force us back through this function if there was + ;; some sort of error above. + (remove-hook 'post-command-hook 'semantic-complete-post-command-hook) + + ;;(message "Exiting inline completion.") + ) + +(defun semantic-complete-pre-command-hook () + "Used to redefine what commands are being run while completing. +When installed as a `pre-command-hook' the special keymap +`semantic-complete-inline-map' is queried to replace commands normally run. +Commands which edit what is in the region of interest operate normally. +Commands which would take us out of the region of interest, or our +quit hook, will exit this completion mode." + (let ((fcn (lookup-key semantic-complete-inline-map + (this-command-keys) nil))) + (cond ((commandp fcn) + (setq this-command fcn)) + (t nil))) + ) + +(defun semantic-complete-post-command-hook () + "Used to determine if we need to exit inline completion mode. +If completion mode is active, check to see if we are within +the bounds of `semantic-complete-inline-overlay', or within +a reasonable distance." + (condition-case nil + ;; Exit if something bad happened. + (if (not semantic-complete-inline-overlay) + (progn + ;;(message "Inline Hook installed, but overlay deleted.") + (semantic-complete-inline-exit)) + ;; Exit if commands caused us to exit the area of interest + (let ((s (semantic-overlay-start semantic-complete-inline-overlay)) + (e (semantic-overlay-end semantic-complete-inline-overlay)) + (b (semantic-overlay-buffer semantic-complete-inline-overlay)) + (txt nil) + ) + (cond + ;; EXIT when we are no longer in a good place. + ((or (not (eq b (current-buffer))) + (< (point) s) + (> (point) e)) + ;;(message "Exit: %S %S %S" s e (point)) + (semantic-complete-inline-exit) + ) + ;; Exit if the user typed in a character that is not part + ;; of the symbol being completed. + ((and (setq txt (semantic-completion-text)) + (not (string= txt "")) + (and (/= (point) s) + (save-excursion + (forward-char -1) + (not (looking-at "\\(\\w\\|\\s_\\)"))))) + ;;(message "Non symbol character.") + (semantic-complete-inline-exit)) + ((lookup-key semantic-complete-inline-map + (this-command-keys) nil) + ;; If the last command was one of our completion commands, + ;; then do nothing. + nil + ) + (t + ;; Else, show completions now + (semantic-complete-inline-force-display) + + )))) + ;; If something goes terribly wrong, clean up after ourselves. + (error (semantic-complete-inline-exit)))) + +(defun semantic-complete-inline-force-display () + "Force the display of whatever the current completions are. +DO NOT CALL THIS IF THE INLINE COMPLETION ENGINE IS NOT ACTIVE." + (condition-case e + (save-excursion + (let ((collector semantic-completion-collector-engine) + (displayor semantic-completion-display-engine) + (contents (semantic-completion-text))) + (when collector + (semantic-collector-calculate-completions + collector contents nil) + (semantic-displayor-set-completions + displayor + (semantic-collector-all-completions collector contents) + contents) + ;; Ask the displayor to display them. + (semantic-displayor-show-request displayor)) + )) + (error (message "Bug Showing Completions: %S" e)))) + +(defun semantic-complete-inline-tag-engine + (collector displayor buffer start end) + "Perform completion based on semantic tags in a buffer. +Argument COLLECTOR is an object which can be used to to calculate +a list of possible hits. See `semantic-completion-collector-engine' +for details on COLLECTOR. +Argumeng DISPLAYOR is an object used to display a list of possible +completions for a given prefix. See`semantic-completion-display-engine' +for details on DISPLAYOR. +BUFFER is the buffer in which completion will take place. +START is a location for the start of the full symbol. +If the symbol being completed is \"foo.ba\", then START +is on the \"f\" character. +END is at the end of the current symbol being completed." + ;; Set us up for doing completion + (setq semantic-completion-collector-engine collector + semantic-completion-display-engine displayor) + ;; Create an overlay + (setq semantic-complete-inline-overlay + (semantic-make-overlay start end buffer nil t)) + (semantic-overlay-put semantic-complete-inline-overlay + 'face + 'semantic-complete-inline-face) + (semantic-overlay-put semantic-complete-inline-overlay + 'window-config-start + (current-window-configuration)) + ;; Install our command hooks + (add-hook 'pre-command-hook 'semantic-complete-pre-command-hook) + (add-hook 'post-command-hook 'semantic-complete-post-command-hook) + ;; Go! + (semantic-complete-inline-force-display) + ) + +;;; Inline Completion Keymap Functions +;; +(defun semantic-complete-inline-TAB () + "Perform inline completion." + (interactive) + (let ((cmpl (semantic-complete-do-completion nil t))) + (cond + ((eq cmpl 'complete) + (semantic-complete-inline-force-display)) + ((eq cmpl 'done) + (semantic-complete-inline-done)) + )) + ) + +(defun semantic-complete-inline-down() + "Focus forwards through the displayor." + (interactive) + (let ((displayor semantic-completion-display-engine)) + (semantic-displayor-focus-next displayor) + (semantic-displayor-focus-request displayor) + )) + +(defun semantic-complete-inline-up () + "Focus backwards through the displayor." + (interactive) + (let ((displayor semantic-completion-display-engine)) + (semantic-displayor-focus-previous displayor) + (semantic-displayor-focus-request displayor) + )) + + +;;; ------------------------------------------------------------ +;;; Interactions between collection and displaying +;; +;; Functional routines used to help collectors communicate with +;; the current displayor, or for the previous section. + +(defun semantic-complete-next-action (partial) + "Determine what the next completion action should be. +PARTIAL is non-nil if we are doing partial completion. +First, the collector can determine if we should perform a completion or not. +If there is nothing to complete, then the displayor determines if we are +to show a completion list, scroll, or perhaps do a focus (if it is capable.) +Expected return values are: + done -> We have a singular match + empty -> There are no matches to the current text + complete -> Perform a completion action + complete-whitespace -> Complete next whitespace type character. + display -> Show the list of completions + scroll -> The completions have been shown, and the user keeps hitting + the complete button. If possible, scroll the completions + focus -> The displayor knows how to shift focus among possible completions. + Let it do that. + displayend -> Whatever options the displayor had for repeating options, there + are none left. Try something new." + (let ((ans1 (semantic-collector-next-action + semantic-completion-collector-engine + partial)) + (ans2 (semantic-displayor-next-action + semantic-completion-display-engine)) + ) + (cond + ;; No collector answer, use displayor answer. + ((not ans1) + ans2) + ;; Displayor selection of 'scroll, 'display, or 'focus trumps + ;; 'done + ((and (eq ans1 'done) ans2) + ans2) + ;; Use ans1 when we have it. + (t + ans1)))) + + + +;;; ------------------------------------------------------------ +;;; Collection Engines +;; +;; Collection engines can scan tags from the current environment and +;; provide lists of possible completions. +;; +;; General features of the abstract collector: +;; * Cache completion lists between uses +;; * Cache itself per buffer. Handle reparse hooks +;; +;; Key Interface Functions to implement: +;; * semantic-collector-next-action +;; * semantic-collector-calculate-completions +;; * semantic-collector-try-completion +;; * semantic-collector-all-completions + +(defvar semantic-collector-per-buffer-list nil + "List of collectors active in this buffer.") +(make-variable-buffer-local 'semantic-collector-per-buffer-list) + +(defvar semantic-collector-list nil + "List of global collectors active this session.") + +(defclass semantic-collector-abstract () + ((buffer :initarg :buffer + :type buffer + :documentation "Originating buffer for this collector. +Some collectors use a given buffer as a starting place while looking up +tags.") + (cache :initform nil + :type (or null semanticdb-find-result-with-nil) + :documentation "Cache of tags. +These tags are re-used during a completion session. +Sometimes these tags are cached between completion sessions.") + (last-all-completions :initarg nil + :type semanticdb-find-result-with-nil + :documentation "Last result of `all-completions'. +This result can be used for refined completions as `last-prefix' gets +closer to a specific result.") + (last-prefix :type string + :protection :protected + :documentation "The last queried prefix. +This prefix can be used to cache intermediate completion offers. +making the action of homing in on a token faster.") + (last-completion :type (or null string) + :documentation "The last calculated completion. +This completion is calculated and saved for future use.") + (last-whitespace-completion :type (or null string) + :documentation "The last whitespace completion. +For partial completion, SPC will disabiguate over whitespace type +characters. This is the last calculated version.") + (current-exact-match :type list + :protection :protected + :documentation "The list of matched tags. +When tokens are matched, they are added to this list.") + ) + "Root class for completion engines. +The baseclass provides basic functionality for interacting with +a completion displayor object, and tracking the current progress +of a completion." + :abstract t) + +(defmethod semantic-collector-cleanup ((obj semantic-collector-abstract)) + "Clean up any mess this collector may have." + nil) + +(defmethod semantic-collector-next-action + ((obj semantic-collector-abstract) partial) + "What should we do next? OBJ can predict a next good action. +PARTIAL indicates if we are doing a partial completion." + (if (and (slot-boundp obj 'last-completion) + (string= (semantic-completion-text) (oref obj last-completion))) + (let* ((cem (semantic-collector-current-exact-match obj)) + (cemlen (semanticdb-find-result-length cem)) + (cac (semantic-collector-all-completions + obj (semantic-completion-text))) + (caclen (semanticdb-find-result-length cac))) + (cond ((and cem (= cemlen 1) + cac (> caclen 1) + (eq last-command this-command)) + ;; Defer to the displayor... + nil) + ((and cem (= cemlen 1)) + 'done) + ((and (not cem) (not cac)) + 'empty) + ((and partial (semantic-collector-try-completion-whitespace + obj (semantic-completion-text))) + 'complete-whitespace))) + 'complete)) + +(defmethod semantic-collector-last-prefix= ((obj semantic-collector-abstract) + last-prefix) + "Return non-nil if OBJ's prefix matches PREFIX." + (and (slot-boundp obj 'last-prefix) + (string= (oref obj last-prefix) last-prefix))) + +(defmethod semantic-collector-get-cache ((obj semantic-collector-abstract)) + "Get the raw cache of tags for completion. +Calculate the cache if there isn't one." + (or (oref obj cache) + (semantic-collector-calculate-cache obj))) + +(defmethod semantic-collector-calculate-completions-raw + ((obj semantic-collector-abstract) prefix completionlist) + "Calculate the completions for prefix from completionlist. +Output must be in semanticdb Find result format." + ;; Must output in semanticdb format + (let ((table (save-excursion + (set-buffer (oref obj buffer)) + semanticdb-current-table)) + (result (semantic-find-tags-for-completion + prefix + ;; To do this kind of search with a pre-built completion + ;; list, we need to strip it first. + (semanticdb-strip-find-results completionlist))) + ) + (if result + (list (cons table result))))) + +(defmethod semantic-collector-calculate-completions + ((obj semantic-collector-abstract) prefix partial) + "Calculate completions for prefix as setup for other queries." + (let* ((case-fold-search semantic-case-fold) + (same-prefix-p (semantic-collector-last-prefix= obj prefix)) + (completionlist + (if (or same-prefix-p + (and (slot-boundp obj 'last-prefix) + (eq (compare-strings (oref obj last-prefix) 0 nil + prefix 0 (length prefix)) + t))) + ;; New prefix is subset of old prefix + (oref obj last-all-completions) + (semantic-collector-get-cache obj))) + ;; Get the result + (answer (if same-prefix-p + completionlist + (semantic-collector-calculate-completions-raw + obj prefix completionlist)) + ) + (completion nil) + (complete-not-uniq nil) + ) + ;;(semanticdb-find-result-test answer) + (when (not same-prefix-p) + ;; Save results if it is interesting and beneficial + (oset obj last-prefix prefix) + (oset obj last-all-completions answer)) + ;; Now calculate the completion. + (setq completion (try-completion + prefix + (semanticdb-strip-find-results answer))) + (oset obj last-whitespace-completion nil) + (oset obj current-exact-match nil) + ;; Only do this if a completion was found. Letting a nil in + ;; could cause a full semanticdb search by accident. + (when completion + (oset obj last-completion + (cond + ;; Unique match in AC. Last completion is a match. + ;; Also set the current-exact-match. + ((eq completion t) + (oset obj current-exact-match answer) + prefix) + ;; It may be complete (a symbol) but still not unique. + ;; We can capture a match + ((setq complete-not-uniq + (semanticdb-find-tags-by-name + prefix + answer)) + (oset obj current-exact-match + complete-not-uniq) + prefix + ) + ;; Non unique match, return the string that handles + ;; completion + (t (or completion prefix)) + ))) + )) + +(defmethod semantic-collector-try-completion-whitespace + ((obj semantic-collector-abstract) prefix) + "For OBJ, do whatepsace completion based on PREFIX. +This implies that if there are two completions, one matching +the test \"preifx\\>\", and one not, the one matching the full +word version of PREFIX will be chosen, and that text returned. +This function requires that `semantic-collector-calculate-completions' +has been run first." + (let* ((ac (semantic-collector-all-completions obj prefix)) + (matchme (concat "^" prefix "\\>")) + (compare (semanticdb-find-tags-by-name-regexp matchme ac)) + (numtag (semanticdb-find-result-length compare)) + ) + (if compare + (let* ((idx 0) + (cutlen (1+ (length prefix))) + (twws (semanticdb-find-result-nth compare idx))) + ;; Is our tag with whitespace a match that has whitespace + ;; after it, or just an already complete symbol? + (while (and (< idx numtag) + (< (length (semantic-tag-name (car twws))) cutlen)) + (setq idx (1+ idx) + twws (semanticdb-find-result-nth compare idx))) + (when (and twws (car-safe twws)) + ;; If COMPARE has succeeded, then we should take the very + ;; first match, and extend prefix by one character. + (oset obj last-whitespace-completion + (substring (semantic-tag-name (car twws)) + 0 cutlen)))) + ))) + + +(defmethod semantic-collector-current-exact-match ((obj semantic-collector-abstract)) + "Return the active valid MATCH from the semantic collector. +For now, just return the first element from our list of available +matches. For semanticdb based results, make sure the file is loaded +into a buffer." + (when (slot-boundp obj 'current-exact-match) + (oref obj current-exact-match))) + +(defmethod semantic-collector-current-whitespace-completion ((obj semantic-collector-abstract)) + "Return the active whitespace completion value." + (when (slot-boundp obj 'last-whitespace-completion) + (oref obj last-whitespace-completion))) + +(defmethod semantic-collector-get-match ((obj semantic-collector-abstract)) + "Return the active valid MATCH from the semantic collector. +For now, just return the first element from our list of available +matches. For semanticdb based results, make sure the file is loaded +into a buffer." + (when (slot-boundp obj 'current-exact-match) + (semanticdb-find-result-nth-in-buffer (oref obj current-exact-match) 0))) + +(defmethod semantic-collector-all-completions + ((obj semantic-collector-abstract) prefix) + "For OBJ, retrieve all completions matching PREFIX. +The returned list consists of all the tags currently +matching PREFIX." + (when (slot-boundp obj 'last-all-completions) + (oref obj last-all-completions))) + +(defmethod semantic-collector-try-completion + ((obj semantic-collector-abstract) prefix) + "For OBJ, attempt to match PREFIX. +See `try-completion' for details on how this works. +Return nil for no match. +Return a string for a partial match. +For a unique match of PREFIX, return the list of all tags +with that name." + (if (slot-boundp obj 'last-completion) + (oref obj last-completion))) + +(defmethod semantic-collector-calculate-cache + ((obj semantic-collector-abstract)) + "Calculate the completion cache for OBJ." + nil + ) + +(defmethod semantic-collector-flush ((this semantic-collector-abstract)) + "Flush THIS collector object, clearing any caches and prefix." + (oset this cache nil) + (slot-makeunbound this 'last-prefix) + (slot-makeunbound this 'last-completion) + (slot-makeunbound this 'last-all-completions) + (slot-makeunbound this 'current-exact-match) + ) + +;;; PER BUFFER +;; +(defclass semantic-collector-buffer-abstract (semantic-collector-abstract) + () + "Root class for per-buffer completion engines. +These collectors track themselves on a per-buffer basis." + :abstract t) + +(defmethod constructor :STATIC ((this semantic-collector-buffer-abstract) + newname &rest fields) + "Reuse previously created objects of this type in buffer." + (let ((old nil) + (bl semantic-collector-per-buffer-list)) + (while (and bl (null old)) + (if (eq (object-class (car bl)) this) + (setq old (car bl)))) + (unless old + (let ((new (call-next-method))) + (add-to-list 'semantic-collector-per-buffer-list new) + (setq old new))) + (slot-makeunbound old 'last-completion) + (slot-makeunbound old 'last-prefix) + (slot-makeunbound old 'current-exact-match) + old)) + +;; Buffer specific collectors should flush themselves +(defun semantic-collector-buffer-flush (newcache) + "Flush all buffer collector objects. +NEWCACHE is the new tag table, but we ignore it." + (condition-case nil + (let ((l semantic-collector-per-buffer-list)) + (while l + (if (car l) (semantic-collector-flush (car l))) + (setq l (cdr l)))) + (error nil))) + +(add-hook 'semantic-after-toplevel-cache-change-hook + 'semantic-collector-buffer-flush) + +;;; DEEP BUFFER SPECIFIC COMPLETION +;; +(defclass semantic-collector-buffer-deep + (semantic-collector-buffer-abstract) + () + "Completion engine for tags in the current buffer. +When searching for a tag, uses semantic deep searche functions. +Basics search only in the current buffer.") + +(defmethod semantic-collector-calculate-cache + ((obj semantic-collector-buffer-deep)) + "Calculate the completion cache for OBJ. +Uses `semantic-flatten-tags-table'" + (oset obj cache + ;; Must create it in SEMANTICDB find format. + ;; ( ( DBTABLE TAG TAG ... ) ... ) + (list + (cons semanticdb-current-table + (semantic-flatten-tags-table (oref obj buffer)))))) + +;;; PROJECT SPECIFIC COMPLETION +;; +(defclass semantic-collector-project-abstract (semantic-collector-abstract) + ((path :initarg :path + :initform nil + :documentation "List of database tables to search. +At creation time, it can be anything accepted by +`semanticdb-find-translate-path' as a PATH argument.") + ) + "Root class for project wide completion engines. +Uses semanticdb for searching all tags in the current project." + :abstract t) + +;;; Project Search +(defclass semantic-collector-project (semantic-collector-project-abstract) + () + "Completion engine for tags in a project.") + + +(defmethod semantic-collector-calculate-completions-raw + ((obj semantic-collector-project) prefix completionlist) + "Calculate the completions for prefix from completionlist." + (semanticdb-find-tags-for-completion prefix (oref obj path))) + +;;; Brutish Project search +(defclass semantic-collector-project-brutish (semantic-collector-project-abstract) + () + "Completion engine for tags in a project.") + +(defmethod semantic-collector-calculate-completions-raw + ((obj semantic-collector-project-brutish) prefix completionlist) + "Calculate the completions for prefix from completionlist." + (semanticdb-brute-deep-find-tags-for-completion prefix (oref obj path))) + +(defclass semantic-collector-analyze-completions (semantic-collector-abstract) + ((context :initarg :context + :type semantic-analyze-context + :documentation "An analysis context. +Specifies some context location from whence completion lists will be drawn." + ) + (first-pass-completions :type list + :documentation "List of valid completion tags. +This list of tags is generated when completion starts. All searches +derive from this list.") + ) + "Completion engine that uses the context analyzer to provide options. +The only options available for completion are those which can be logically +inserted into the current context.") + +(defmethod semantic-collector-calculate-completions-raw + ((obj semantic-collector-analyze-completions) prefix completionlist) + "calculate the completions for prefix from completionlist." + ;; if there are no completions yet, calculate them. + (if (not (slot-boundp obj 'first-pass-completions)) + (oset obj first-pass-completions + (semantic-analyze-possible-completions (oref obj context)))) + ;; search our cached completion list. make it look like a semanticdb + ;; results type. + (list (cons (save-excursion + (set-buffer (oref (oref obj context) buffer)) + semanticdb-current-table) + (semantic-find-tags-for-completion + prefix + (oref obj first-pass-completions))))) + + +;;; ------------------------------------------------------------ +;;; Tag List Display Engines +;; +;; A typical displayor accepts a pre-determined list of completions +;; generated by a collector. This format is in semanticdb search +;; form. This vaguely standard form is a bit challenging to navigate +;; because the tags do not contain buffer info, but the file assocated +;; with the tags preceed the tag in the list. +;; +;; Basic displayors don't care, and can strip the results. +;; Advanced highlighting displayors need to know when they need +;; to load a file so that the tag in question can be highlighted. +;; +;; Key interface methods to a displayor are: +;; * semantic-displayor-next-action +;; * semantic-displayor-set-completions +;; * semantic-displayor-current-focus +;; * semantic-displayor-show-request +;; * semantic-displayor-scroll-request +;; * semantic-displayor-focus-request + +(defclass semantic-displayor-abstract () + ((table :type (or null semanticdb-find-result-with-nil) + :initform nil + :protection :protected + :documentation "List of tags this displayor is showing.") + (last-prefix :type string + :protection :protected + :documentation "Prefix associated with slot `table'") + ) + "Abstract displayor baseclass. +Manages the display of some number of tags. +Provides the basics for a displayor, including interacting with +a collector, and tracking tables of completion to display." + :abstract t) + +(defmethod semantic-displayor-cleanup ((obj semantic-displayor-abstract)) + "Clean up any mess this displayor may have." + nil) + +(defmethod semantic-displayor-next-action ((obj semantic-displayor-abstract)) + "The next action to take on the minibuffer related to display." + (if (and (slot-boundp obj 'last-prefix) + (string= (oref obj last-prefix) (semantic-completion-text)) + (eq last-command this-command)) + 'scroll + 'display)) + +(defmethod semantic-displayor-set-completions ((obj semantic-displayor-abstract) + table prefix) + "Set the list of tags to be completed over to TABLE." + (oset obj table table) + (oset obj last-prefix prefix)) + +(defmethod semantic-displayor-show-request ((obj semantic-displayor-abstract)) + "A request to show the current tags table." + (ding)) + +(defmethod semantic-displayor-focus-request ((obj semantic-displayor-abstract)) + "A request to for the displayor to focus on some tag option." + (ding)) + +(defmethod semantic-displayor-scroll-request ((obj semantic-displayor-abstract)) + "A request to for the displayor to scroll the completion list (if needed)." + (scroll-other-window)) + +(defmethod semantic-displayor-focus-previous ((obj semantic-displayor-abstract)) + "Set the current focus to the previous item." + nil) + +(defmethod semantic-displayor-focus-next ((obj semantic-displayor-abstract)) + "Set the current focus to the next item." + nil) + +(defmethod semantic-displayor-current-focus ((obj semantic-displayor-abstract)) + "Return a single tag currently in focus. +This object type doesn't do focus, so will never have a focus object." + nil) + +;; Traditional displayor +(defcustom semantic-completion-displayor-format-tag-function + #'semantic-format-tag-name + "*A Tag format function to use when showing completions." + :group 'semantic + :type semantic-format-tag-custom-list) + +(defclass semantic-displayor-traditional (semantic-displayor-abstract) + () + "Display options in *Completions* buffer. +Traditional display mechanism for a list of possible completions. +Completions are showin in a new buffer and listed with the ability +to click on the items to aid in completion.") + +(defmethod semantic-displayor-show-request ((obj semantic-displayor-traditional)) + "A request to show the current tags table." + + ;; NOTE TO SELF. Find the character to type next, and emphesize it. + + (with-output-to-temp-buffer "*Completions*" + (display-completion-list + (mapcar semantic-completion-displayor-format-tag-function + (semanticdb-strip-find-results (oref obj table)))) + ) + ) + +;;; Abstract baseclass for any displayor which supports focus +(defclass semantic-displayor-focus-abstract (semantic-displayor-abstract) + ((focus :type number + :protection :protected + :documentation "A tag index from `table' which has focus. +Multiple calls to the display function can choose to focus on a +given tag, by highlighting its location.") + (find-file-focus + :allocation :class + :initform nil + :documentation + "Non-nil if focusing requires a tag's buffer be in memory.") + ) + "Abstract displayor supporting `focus'. +A displayor which has the ability to focus in on one tag. +Focusing is a way of differentiationg between multiple tags +which have the same name." + :abstract t) + +(defmethod semantic-displayor-next-action ((obj semantic-displayor-focus-abstract)) + "The next action to take on the minibuffer related to display." + (if (and (slot-boundp obj 'last-prefix) + (string= (oref obj last-prefix) (semantic-completion-text)) + (eq last-command this-command)) + (if (and + (slot-boundp obj 'focus) + (slot-boundp obj 'table) + (<= (semanticdb-find-result-length (oref obj table)) + (1+ (oref obj focus)))) + ;; We are at the end of the focus road. + 'displayend + ;; Focus on some item. + 'focus) + 'display)) + +(defmethod semantic-displayor-set-completions ((obj semantic-displayor-focus-abstract) + table prefix) + "Set the list of tags to be completed over to TABLE." + (call-next-method) + (slot-makeunbound obj 'focus)) + +(defmethod semantic-displayor-focus-previous ((obj semantic-displayor-focus-abstract)) + "Set the current focus to the previous item. +Not meaningful return value." + (when (and (slot-boundp obj 'table) (oref obj table)) + (with-slots (table) obj + (if (or (not (slot-boundp obj 'focus)) + (<= (oref obj focus) 0)) + (oset obj focus (1- (semanticdb-find-result-length table))) + (oset obj focus (1- (oref obj focus))) + ) + ))) + +(defmethod semantic-displayor-focus-next ((obj semantic-displayor-focus-abstract)) + "Set the current focus to the next item. +Not meaningful return value." + (when (and (slot-boundp obj 'table) (oref obj table)) + (with-slots (table) obj + (if (not (slot-boundp obj 'focus)) + (oset obj focus 0) + (oset obj focus (1+ (oref obj focus))) + ) + (if (<= (semanticdb-find-result-length table) (oref obj focus)) + (oset obj focus 0)) + ))) + +(defmethod semantic-displayor-focus-tag ((obj semantic-displayor-focus-abstract)) + "Return the next tag OBJ should focus on." + (when (and (slot-boundp obj 'table) (oref obj table)) + (with-slots (table) obj + (semanticdb-find-result-nth table (oref obj focus))))) + +(defmethod semantic-displayor-current-focus ((obj semantic-displayor-focus-abstract)) + "Return the tag currently in focus, or call parent method." + (if (and (slot-boundp obj 'focus) + (slot-boundp obj 'table) + ;; Only return the current focus IFF the minibuffer reflects + ;; the list this focus was derived from. + (slot-boundp obj 'last-prefix) + (string= (semantic-completion-text) (oref obj last-prefix)) + ) + ;; We need to focus + (if (oref obj find-file-focus) + (semanticdb-find-result-nth-in-buffer (oref obj table) (oref obj focus)) + ;; result-nth returns a cons with car being the tag, and cdr the + ;; database. + (car (semanticdb-find-result-nth (oref obj table) (oref obj focus)))) + ;; Do whatever + (call-next-method))) + +;;; Simple displayor which performs traditional display completion, +;; and also focuses with highlighting. +(defclass semantic-displayor-traditional-with-focus-highlight + (semantic-displayor-focus-abstract semantic-displayor-traditional) + ((find-file-focus :initform t)) + "Display completions in *Completions* buffer, with focus highlight. +A traditional displayor which can focus on a tag by showing it. +Same as `semantic-displayor-traditional', but with selection between +multiple tags with the same name done by 'focusing' on the source +location of the different tags to differentiate them.") + +(defmethod semantic-displayor-focus-request + ((obj semantic-displayor-traditional-with-focus-highlight)) + "Focus in on possible tag completions. +Focus is performed by cycling through the tags and highlighting +one in the source buffer." + (let* ((tablelength (semanticdb-find-result-length (oref obj table))) + (focus (semantic-displayor-focus-tag obj)) + ;; Raw tag info. + (rtag (car focus)) + (rtable (cdr focus)) + ;; Normalize + (nt (semanticdb-normalize-one-tag rtable rtag)) + (tag (cdr nt)) + (table (car nt)) + ) + ;; If we fail to normalize, resete. + (when (not tag) (setq table rtable tag rtag)) + ;; Do the focus. + (let ((buf (or (semantic-tag-buffer tag) + (and table (semanticdb-get-buffer table))))) + ;; If no buffer is provided, then we can make up a summary buffer. + (when (not buf) + (save-excursion + (set-buffer (get-buffer-create "*Completion Focus*")) + (erase-buffer) + (insert "Focus on tag: \n") + (insert (semantic-format-tag-summarize tag nil t) "\n\n") + (when table + (insert "From table: \n") + (insert (object-name table) "\n\n")) + (when buf + (insert "In buffer: \n\n") + (insert (format "%S" buf))) + (setq buf (current-buffer)))) + ;; Show the tag in the buffer. + (if (get-buffer-window buf) + (select-window (get-buffer-window buf)) + (switch-to-buffer-other-window buf t) + (select-window (get-buffer-window buf))) + ;; Now do some positioning + (unwind-protect + (if (semantic-tag-with-position-p tag) + ;; Full tag positional information available + (progn + (goto-char (semantic-tag-start tag)) + ;; This avoids a dangerous problem if we just loaded a tag + ;; from a file, but the original position was not updated + ;; in the TAG variable we are currently using. + (semantic-momentary-highlight-tag (semantic-current-tag)) + )) + (select-window (minibuffer-window))) + ;; Calculate text difference between contents and the focus item. + (let* ((mbc (semantic-completion-text)) + (ftn (semantic-tag-name tag)) + (diff (substring ftn (length mbc)))) + (semantic-completion-message + (format "%s [%d of %d matches]" diff (1+ (oref obj focus)) tablelength))) + ))) + + +;;; Tooltip completion lister +;; +;; Written and contributed by Masatake YAMATO +;; +;; 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 + + +;;; Ghost Text displayor +;; +(defclass semantic-displayor-ghost (semantic-displayor-focus-abstract) + + ((ghostoverlay :type overlay + :documentation + "The overlay the ghost text is displayed in.") + (first-show :initform t + :documentation + "Non nil if we have not seen our first show request.") + ) + "Cycle completions inline with ghost text. +Completion displayor using ghost chars after point for focus options. +Whichever completion is currently in focus will be displayed as ghost +text using overlay options.") + +(defmethod semantic-displayor-next-action ((obj semantic-displayor-ghost)) + "The next action to take on the inline completion related to display." + (let ((ans (call-next-method)) + (table (when (slot-boundp obj 'table) + (oref obj table)))) + (if (and (eq ans 'displayend) + table + (= (semanticdb-find-result-length table) 1) + ) + nil + ans))) + +(defmethod semantic-displayor-cleanup ((obj semantic-displayor-ghost)) + "Clean up any mess this displayor may have." + (when (slot-boundp obj 'ghostoverlay) + (semantic-overlay-delete (oref obj ghostoverlay))) + ) + +(defmethod semantic-displayor-set-completions ((obj semantic-displayor-ghost) + table prefix) + "Set the list of tags to be completed over to TABLE." + (call-next-method) + + (semantic-displayor-cleanup obj) + ) + + +(defmethod semantic-displayor-show-request ((obj semantic-displayor-ghost)) + "A request to show the current tags table." +; (if (oref obj first-show) +; (progn +; (oset obj first-show nil) + (semantic-displayor-focus-next obj) + (semantic-displayor-focus-request obj) +; ) + ;; Only do the traditional thing if the first show request + ;; has been seen. Use the first one to start doing the ghost + ;; text display. +; (call-next-method) +; ) +) + +(defmethod semantic-displayor-focus-request + ((obj semantic-displayor-ghost)) + "Focus in on possible tag completions. +Focus is performed by cycling through the tags and showing a possible +completion text in ghost text." + (let* ((tablelength (semanticdb-find-result-length (oref obj table))) + (focus (semantic-displayor-focus-tag obj)) + (tag (car focus)) + ) + (if (not tag) + (semantic-completion-message "No tags to focus on.") + ;; Display the focus completion as ghost text after the current + ;; inline text. + (when (or (not (slot-boundp obj 'ghostoverlay)) + (not (semantic-overlay-live-p (oref obj ghostoverlay)))) + (oset obj ghostoverlay + (semantic-make-overlay (point) (1+ (point)) (current-buffer) t))) + + (let* ((lp (semantic-completion-text)) + (os (substring (semantic-tag-name tag) (length lp))) + (ol (oref obj ghostoverlay)) + ) + + (put-text-property 0 (length os) 'face 'region os) + + (semantic-overlay-put + ol 'display (concat os (buffer-substring (point) (1+ (point))))) + ) + ;; Calculate text difference between contents and the focus item. + (let* ((mbc (semantic-completion-text)) + (ftn (concat (semantic-tag-name tag))) + ) + (put-text-property (length mbc) (length ftn) 'face + 'bold ftn) + (semantic-completion-message + (format "%s [%d of %d matches]" ftn (1+ (oref obj focus)) tablelength))) + ))) + + +;;; ------------------------------------------------------------ +;;; Specific queries +;; +(defun semantic-complete-read-tag-buffer-deep (prompt &optional + default-tag + initial-input + history) + "Ask for a tag by name from the current buffer. +Available tags are from the current buffer, at any level. +Completion options are presented in a traditional way, with highlighting +to resolve same-name collisions. +PROMPT is a string to prompt with. +DEFAULT-TAG is a semantic tag or string to use as the default value. +If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. +HISTORY is a symbol representing a variable to store the history in." + (semantic-complete-read-tag-engine + (semantic-collector-buffer-deep prompt :buffer (current-buffer)) + (semantic-displayor-traditional-with-focus-highlight "simple") + ;;(semantic-displayor-tooltip "simple") + prompt + default-tag + initial-input + history) + ) + +(defun semantic-complete-read-tag-project (prompt &optional + default-tag + initial-input + history) + "Ask for a tag by name from the current project. +Available tags are from the current project, at the top level. +Completion options are presented in a traditional way, with highlighting +to resolve same-name collisions. +PROMPT is a string to prompt with. +DEFAULT-TAG is a semantic tag or string to use as the default value. +If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. +HISTORY is a symbol representing a variable to store the history in." + (semantic-complete-read-tag-engine + (semantic-collector-project-brutish prompt + :buffer (current-buffer) + :path (current-buffer) + ) + (semantic-displayor-traditional-with-focus-highlight "simple") + prompt + default-tag + initial-input + history) + ) + +(defun semantic-complete-inline-tag-project () + "Complete a symbol name by name from within the current project. +This is similar to `semantic-complete-read-tag-project', except +that the completion interaction is in the buffer where the context +was calculated from. +Customize `semantic-complete-inline-analyzer-displayor-class' +to control how completion options are displayed. +See `semantic-complete-inline-tag-engine' for details on how +completion works." + (let* ((collector (semantic-collector-project-brutish + "inline" + :buffer (current-buffer) + :path (current-buffer))) + (sbounds (semantic-ctxt-current-symbol-and-bounds)) + (syms (car sbounds)) + (start (car (nth 2 sbounds))) + (end (cdr (nth 2 sbounds))) + (rsym (reverse syms)) + (thissym (nth 1 sbounds)) + (nextsym (car-safe (cdr rsym))) + (complst nil)) + (when (and thissym (or (not (string= thissym "")) + nextsym)) + ;; Do a quick calcuation of completions. + (semantic-collector-calculate-completions + collector thissym nil) + ;; Get the master list + (setq complst (semanticdb-strip-find-results + (semantic-collector-all-completions collector thissym))) + ;; Shorten by name + (setq complst (semantic-unique-tag-table-by-name complst)) + (if (or (and (= (length complst) 1) + ;; Check to see if it is the same as what is there. + ;; if so, we can offer to complete. + (let ((compname (semantic-tag-name (car complst)))) + (not (string= compname thissym)))) + (> (length complst) 1)) + ;; There are several options. Do the completion. + (semantic-complete-inline-tag-engine + collector + (funcall semantic-complete-inline-analyzer-displayor-class + "inline displayor") + ;;(semantic-displayor-tooltip "simple") + (current-buffer) + start end)) + ))) + +(defun semantic-complete-read-tag-analyzer (prompt &optional + context + history) + "Ask for a tag by name based on the current context. +The function `semantic-analyze-current-context' is used to +calculate the context. `semantic-analyze-possible-completions' is used +to generate the list of possible completions. +PROMPT is the first part of the prompt. Additional prompt +is added based on the contexts full prefix. +CONTEXT is the semantic analyzer context to start with. +HISTORY is a symbol representing a variable to stor the history in. +usually a default-tag and initial-input are available for completion +prompts. these are calculated from the CONTEXT variable passed in." + (if (not context) (setq context (semantic-analyze-current-context (point)))) + (let* ((syms (semantic-ctxt-current-symbol (point))) + (inp (car (reverse syms)))) + (setq syms (nreverse (cdr (nreverse syms)))) + (semantic-complete-read-tag-engine + (semantic-collector-analyze-completions + prompt + :buffer (oref context buffer) + :context context) + (semantic-displayor-traditional-with-focus-highlight "simple") + (save-excursion + (set-buffer (oref context buffer)) + (goto-char (cdr (oref context bounds))) + (concat prompt (mapconcat 'identity syms ".") + (if syms "." "") + )) + nil + inp + history))) + +(defvar semantic-complete-inline-custom-type + (append '(radio) + (mapcar + (lambda (class) + (let* ((C (intern (car class))) + (doc (documentation-property C 'variable-documentation)) + (doc1 (car (split-string doc "\n"))) + ) + (list 'const + :tag doc1 + C))) + (eieio-build-class-alist semantic-displayor-abstract t)) + ) + "Possible options for inlince completion displayors. +Use this to enable custom editing.") + +(defcustom semantic-complete-inline-analyzer-displayor-class + 'semantic-displayor-traditional + "*Class for displayor to use with inline completion." + :group 'semantic + :type semantic-complete-inline-custom-type + ) + + +(defun semantic-complete-inline-analyzer (context) + "Complete a symbol name by name based on the current context. +This is similar to `semantic-complete-read-tag-analyze', except +that the completion interaction is in the buffer where the context +was calculated from. +CONTEXT is the semantic analyzer context to start with. +Customize `semantic-complete-inline-analyzer-displayor-class' +to control how completion options are displayed. + +See `semantic-complete-inline-tag-engine' for details on how +completion works." + (if (not context) (setq context (semantic-analyze-current-context (point)))) + (if (not context) (error "Nothing to complete on here")) + (let* ((collector (semantic-collector-analyze-completions + "inline" + :buffer (oref context buffer) + :context context)) + (syms (semantic-ctxt-current-symbol (point))) + (rsym (reverse syms)) + (thissym (car rsym)) + (nextsym (car-safe (cdr rsym))) + (complst nil)) + (when (and thissym (or (not (string= thissym "")) + nextsym)) + ;; Do a quick calcuation of completions. + (semantic-collector-calculate-completions + collector thissym nil) + ;; Get the master list + (setq complst (semanticdb-strip-find-results + (semantic-collector-all-completions collector thissym))) + ;; Shorten by name + (setq complst (semantic-unique-tag-table-by-name complst)) + (if (or (and (= (length complst) 1) + ;; Check to see if it is the same as what is there. + ;; if so, we can offer to complete. + (let ((compname (semantic-tag-name (car complst)))) + (not (string= compname thissym)))) + (> (length complst) 1)) + ;; There are several options. Do the completion. + (semantic-complete-inline-tag-engine + collector + (funcall semantic-complete-inline-analyzer-displayor-class + "inline displayor") + ;;(semantic-displayor-tooltip "simple") + (oref context buffer) + (car (oref context bounds)) + (cdr (oref context bounds)) + )) + ))) + +(defcustom semantic-complete-inline-analyzer-idle-displayor-class + 'semantic-displayor-ghost + "*Class for displayor to use with inline completion at idle time." + :group 'semantic + :type semantic-complete-inline-custom-type + ) + +(defun semantic-complete-inline-analyzer-idle (context) + "Complete a symbol name by name based on the current context for idle time. +CONTEXT is the semantic analyzer context to start with. +This function is used from `semantic-idle-completions-mode'. + +This is the same as `semantic-complete-inline-analyzer', except that +it uses `semantic-complete-inline-analyzer-idle-displayor-class' +to control how completions are displayed. + +See `semantic-complete-inline-tag-engine' for details on how +completion works." + (let ((semantic-complete-inline-analyzer-displayor-class + semantic-complete-inline-analyzer-idle-displayor-class)) + (semantic-complete-inline-analyzer context) + )) + + +;;; ------------------------------------------------------------ +;;; Testing/Samples +;; +(defun semantic-complete-test () + "Test completion mechanisms." + (interactive) + (message "%S" + (semantic-format-tag-prototype + (semantic-complete-read-tag-project "Symbol: ") + ))) + +(defun semantic-complete-jump-local () + "Jump to a semantic symbol." + (interactive) + (let ((tag (semantic-complete-read-tag-buffer-deep "Symbol: "))) + (when (semantic-tag-p tag) + (push-mark) + (goto-char (semantic-tag-start tag)) + (semantic-momentary-highlight-tag tag) + (message "%S: %s " + (semantic-tag-class tag) + (semantic-tag-name tag))))) + +(defun semantic-complete-jump () + "Jump to a semantic symbol." + (interactive) + (let* ((tag (semantic-complete-read-tag-project "Symbol: "))) + (when (semantic-tag-p tag) + (push-mark) + (semantic-go-to-tag tag) + (switch-to-buffer (current-buffer)) + (semantic-momentary-highlight-tag tag) + (message "%S: %s " + (semantic-tag-class tag) + (semantic-tag-name tag))))) + +(defun semantic-complete-analyze-and-replace () + "Perform prompt completion to do in buffer completion. +`semantic-analyze-possible-completions' is used to determine the +possible values. +The minibuffer is used to perform the completion. +The result is inserted as a replacement of the text that was there." + (interactive) + (let* ((c (semantic-analyze-current-context (point))) + (tag (save-excursion (semantic-complete-read-tag-analyzer "" c)))) + ;; Take tag, and replace context bound with its name. + (goto-char (car (oref c bounds))) + (delete-region (point) (cdr (oref c bounds))) + (insert (semantic-tag-name tag)) + (message "%S" (semantic-format-tag-summarize tag)))) + +(defun semantic-complete-analyze-inline () + "Perform prompt completion to do in buffer completion. +`semantic-analyze-possible-completions' is used to determine the +possible values. +The function returns immediately, leaving the buffer in a mode that +will perform the completion. +Configure `semantic-complete-inline-analyzer-displayor-class' to change +how completion options are displayed." + (interactive) + ;; Only do this if we are not already completing something. + (if (not (semantic-completion-inline-active-p)) + (semantic-complete-inline-analyzer + (semantic-analyze-current-context (point)))) + ;; Report a message if things didn't startup. + (if (and (interactive-p) + (not (semantic-completion-inline-active-p))) + (message "Inline completion not needed.") + ;; Since this is most likely bound to something, and not used + ;; at idle time, throw in a TAB for good measure. + (semantic-complete-inline-TAB) + )) + +(defun semantic-complete-analyze-inline-idle () + "Perform prompt completion to do in buffer completion. +`semantic-analyze-possible-completions' is used to determine the +possible values. +The function returns immediately, leaving the buffer in a mode that +will perform the completion. +Configure `semantic-complete-inline-analyzer-idle-displayor-class' +to change how completion options are displayed." + (interactive) + ;; Only do this if we are not already completing something. + (if (not (semantic-completion-inline-active-p)) + (semantic-complete-inline-analyzer-idle + (semantic-analyze-current-context (point)))) + ;; Report a message if things didn't startup. + (if (and (interactive-p) + (not (semantic-completion-inline-active-p))) + (message "Inline completion not needed.")) + ) + +(defun semantic-complete-self-insert (arg) + "Like `self-insert-command', but does completion afterwards. +ARG is passed to `self-insert-command'. If ARG is nil, +use `semantic-complete-analyze-inline' to complete." + (interactive "p") + ;; If we are already in a completion scenario, exit now, and then start over. + (semantic-complete-inline-exit) + + ;; Insert the key + (self-insert-command arg) + + ;; Prepare for doing completion, but exit quickly if there is keyboard + ;; input. + (when (and (not (semantic-exit-on-input 'csi + (semantic-fetch-tags) + (semantic-throw-on-input 'csi) + nil)) + (= arg 1) + (not (semantic-exit-on-input 'csi + (semantic-analyze-current-context) + (semantic-throw-on-input 'csi) + nil))) + (condition-case nil + (semantic-complete-analyze-inline) + ;; Ignore errors. Seems likely that we'll get some once in a while. + (error nil)) + )) + +;; @TODO - I can't find where this fcn is used. Delete? + +;;;;###autoload +;(defun semantic-complete-inline-project () +; "Perform inline completion for any symbol in the current project. +;`semantic-analyze-possible-completions' is used to determine the +;possible values. +;The function returns immediately, leaving the buffer in a mode that +;will perform the completion." +; (interactive) +; ;; Only do this if we are not already completing something. +; (if (not (semantic-completion-inline-active-p)) +; (semantic-complete-inline-tag-project)) +; ;; Report a message if things didn't startup. +; (if (and (interactive-p) +; (not (semantic-completion-inline-active-p))) +; (message "Inline completion not needed.")) +; ) + +;; End +(provide 'semantic/complete) + +;;; semantic-complete.el ends here diff --git a/lisp/cedet/semantic/edit.el b/lisp/cedet/semantic/edit.el new file mode 100644 index 00000000000..af3b23a3600 --- /dev/null +++ b/lisp/cedet/semantic/edit.el @@ -0,0 +1,965 @@ +;;; 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 + +;; 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 . + +;;; Commentary: +;; +;; In Semantic 1.x, changes were handled in a simplistic manner, where +;; tags that changed were reparsed one at a time. Any other form of +;; edit were managed through a full reparse. +;; +;; This code attempts to minimize the number of times a full reparse +;; needs to occur. While overlays and tags will continue to be +;; recycled in the simple case, new cases where tags are inserted +;; or old tags removed from the original list are handled. +;; + +;;; NOTES FOR IMPROVEMENT +;; +;; Work done by the incremental parser could be improved by the +;; following: +;; +;; 1. Tags created could have as a property an overlay marking a region +;; of themselves that can be edited w/out affecting the definition of +;; that tag. +;; +;; 2. Tags w/ positioned children could have a property of an +;; overlay marking the region in themselves that contain the +;; children. This could be used to better improve splicing near +;; the beginning and end of the child lists. +;; + +;;; BUGS IN INCREMENTAL PARSER +;; +;; 1. Changes in the whitespace between tags could extend a +;; following tag. These will be marked as merely unmatched +;; syntax instead. +;; +;; 2. Incremental parsing while a new function is being typed in +;; somtimes gets a chance only when lists are incomplete, +;; preventing correct context identification. + +;; +(require 'semantic) +;; (require 'working) + +;;; Code: +(defvar semantic-after-partial-cache-change-hook nil + "Hooks run after the buffer cache has been updated. + +This hook will run when the cache has been partially reparsed. +Partial reparses are incurred when a user edits a buffer, and only the +modified sections are rescanned. + +Hook functions must take one argument, which is the list of tags +updated in the current buffer. + +For language specific hooks, make sure you define this as a local hook.") + +(defvar semantic-change-hooks nil + "Hooks run when semantic detects a change in a buffer. +Each hook function must take three arguments, identical to the +common hook `after-change-functions'.") + +(defvar semantic-reparse-needed-change-hook nil + "Hooks run when a user edit is detected as needing a reparse. +For language specific hooks, make sure you define this as a local +hook. +Not used yet; part of the next generation reparse mechanism") + +(defvar semantic-no-reparse-needed-change-hook nil + "Hooks run when a user edit is detected as not needing a reparse. +If the hook returns non-nil, then declare that a reparse is needed. +For language specific hooks, make sure you define this as a local +hook. +Not used yet; part of the next generation reparse mechanism.") + +(defvar semantic-edits-new-change-hooks nil + "Hooks run when a new change is found. +Functions must take one argument representing an overlay on that change.") + +(defvar semantic-edits-delete-change-hooks nil + "Hooks run before a change overlay is deleted. +Deleted changes occur when multiple changes are merged. +Functions must take one argument representing an overlay being deleted.") + +(defvar semantic-edits-move-change-hooks nil + "Hooks run after a change overlay is moved. +Changes move when a new change overlaps an old change. The old change +will be moved. +Functions must take one argument representing an overlay being moved.") + +(defvar semantic-edits-reparse-change-hooks nil + "Hooks run after a change results in a reparse. +Functions are called before the overlay is deleted, and after the +incremental reparse.") + +(defvar semantic-edits-incremental-reparse-failed-hooks nil + "Hooks run after the incremental parser fails. +When this happens, the buffer is marked as needing a full reprase.") + +(defcustom semantic-edits-verbose-flag nil + "Non-nil means the incremental perser is verbose. +If nil, errors are still displayed, but informative messages are not." + :group 'semantic + :type 'boolean) + +;;; Change State management +;; +;; Manage a series of overlays that define changes recently +;; made to the current buffer. +(defun semantic-change-function (start end length) + "Provide a mechanism for semantic tag management. +Argument START, END, and LENGTH specify the bounds of the change." + (setq semantic-unmatched-syntax-cache-check t) + (let ((inhibit-point-motion-hooks t) + ) + (run-hook-with-args 'semantic-change-hooks start end length) + )) + +(defun semantic-changes-in-region (start end &optional buffer) + "Find change overlays which exist in whole or in part between START and END. +Optional argument BUFFER is the buffer to search for changes in." + (save-excursion + (if buffer (set-buffer buffer)) + (let ((ol (semantic-overlays-in (max start (point-min)) + (min end (point-max)))) + (ret nil)) + (while ol + (when (semantic-overlay-get (car ol) 'semantic-change) + (setq ret (cons (car ol) ret))) + (setq ol (cdr ol))) + (sort ret #'(lambda (a b) (< (semantic-overlay-start a) + (semantic-overlay-start b))))))) + +(defun semantic-edits-change-function-handle-changes (start end length) + "Run whenever a buffer controlled by `semantic-mode' change. +Tracks when and how the buffer is re-parsed. +Argument START, END, and LENGTH specify the bounds of the change." + ;; We move start/end by one so that we can merge changes that occur + ;; just before, or just after. This lets simple typing capture everything + ;; into one overlay. + (let ((changes-in-change (semantic-changes-in-region (1- start) (1+ end))) + ) + (semantic-parse-tree-set-needs-update) + (if (not changes-in-change) + (let ((o (semantic-make-overlay start end))) + (semantic-overlay-put o 'semantic-change t) + ;; Run the hooks safely. When hooks blow it, our dirty + ;; function will be removed from the list of active change + ;; functions. + (condition-case nil + (run-hook-with-args 'semantic-edits-new-change-hooks o) + (error nil))) + (let ((tmp changes-in-change)) + ;; Find greatest bounds of all changes + (while tmp + (when (< (semantic-overlay-start (car tmp)) start) + (setq start (semantic-overlay-start (car tmp)))) + (when (> (semantic-overlay-end (car tmp)) end) + (setq end (semantic-overlay-end (car tmp)))) + (setq tmp (cdr tmp))) + ;; Move the first found overlay, recycling that overlay. + (semantic-overlay-move (car changes-in-change) start end) + (condition-case nil + (run-hook-with-args 'semantic-edits-move-change-hooks + (car changes-in-change)) + (error nil)) + (setq changes-in-change (cdr changes-in-change)) + ;; Delete other changes. They are now all bound here. + (while changes-in-change + (condition-case nil + (run-hook-with-args 'semantic-edits-delete-change-hooks + (car changes-in-change)) + (error nil)) + (semantic-overlay-delete (car changes-in-change)) + (setq changes-in-change (cdr changes-in-change)))) + ))) + +(defsubst semantic-edits-flush-change (change) + "Flush the CHANGE overlay." + (condition-case nil + (run-hook-with-args 'semantic-edits-delete-change-hooks + change) + (error nil)) + (semantic-overlay-delete change)) + +(defun semantic-edits-flush-changes () + "Flush the changes in the current buffer." + (let ((changes (semantic-changes-in-region (point-min) (point-max)))) + (while changes + (semantic-edits-flush-change (car changes)) + (setq changes (cdr changes)))) + ) + +(defun semantic-edits-change-in-one-tag-p (change hits) + "Return non-nil of the overlay CHANGE exists solely in one leaf tag. +HITS is the list of tags that CHANGE is in. It can have more than +one tag in it if the leaf tag is within a parent tag." + (and (< (semantic-tag-start (car hits)) + (semantic-overlay-start change)) + (> (semantic-tag-end (car hits)) + (semantic-overlay-end change)) + ;; Recurse on the rest. If this change is inside all + ;; of these tags, then they are all leaves or parents + ;; of the smallest tag. + (or (not (cdr hits)) + (semantic-edits-change-in-one-tag-p change (cdr hits)))) + ) + +;;; Change/Tag Query functions +;; +;; A change (region of space) can effect tags in different ways. +;; These functions perform queries on a buffer to determine different +;; ways that a change effects a buffer. +;; +;; NOTE: After debugging these, replace below to no longer look +;; at point and mark (via comments I assume.) +(defsubst semantic-edits-os (change) + "For testing: Start of CHANGE, or smaller of (point) and (mark)." + (if change (semantic-overlay-start change) + (if (< (point) (mark)) (point) (mark)))) + +(defsubst semantic-edits-oe (change) + "For testing: End of CHANGE, or larger of (point) and (mark)." + (if change (semantic-overlay-end change) + (if (> (point) (mark)) (point) (mark)))) + +(defun semantic-edits-change-leaf-tag (change) + "A leaf tag which completely encompasses CHANGE. +If change overlaps a tag, but is not encompassed in it, return nil. +Use `semantic-edits-change-overlap-leaf-tag'. +If CHANGE is completely encompassed in a tag, but overlaps sub-tags, +return nil." + (let* ((start (semantic-edits-os change)) + (end (semantic-edits-oe change)) + (tags (nreverse + (semantic-find-tag-by-overlay-in-region + start end)))) + ;; A leaf is always first in this list + (if (and tags + (<= (semantic-tag-start (car tags)) start) + (> (semantic-tag-end (car tags)) end)) + ;; Ok, we have a match. If this tag has children, + ;; we have to do more tests. + (let ((chil (semantic-tag-components (car tags)))) + (if (not chil) + ;; Simple leaf. + (car tags) + ;; For this type, we say that we encompass it if the + ;; change occurs outside the range of the children. + (if (or (not (semantic-tag-with-position-p (car chil))) + (> start (semantic-tag-end (nth (1- (length chil)) chil))) + (< end (semantic-tag-start (car chil)))) + ;; We have modifications to the definition of this parent + ;; so we have to reparse the whole thing. + (car tags) + ;; We actually modified an area between some children. + ;; This means we should return nil, as that case is + ;; calculated by someone else. + nil))) + nil))) + +(defun semantic-edits-change-between-tags (change) + "Return a cache list of tags surrounding CHANGE. +The returned list is the CONS cell in the master list pointing to +a tag just before CHANGE. The CDR will have the tag just after CHANGE. +CHANGE cannot encompass or overlap a leaf tag. +If CHANGE is fully encompassed in a tag that has children, and +this change occurs between those children, this returns non-nil. +See `semantic-edits-change-leaf-tag' for details on parents." + (let* ((start (semantic-edits-os change)) + (end (semantic-edits-oe change)) + (tags (nreverse + (semantic-find-tag-by-overlay-in-region + start end))) + (list-to-search nil) + (found nil)) + (if (not tags) + (setq list-to-search semantic--buffer-cache) + ;; A leaf is always first in this list + (if (and (< (semantic-tag-start (car tags)) start) + (> (semantic-tag-end (car tags)) end)) + ;; We are completely encompassed in a tag. + (if (setq list-to-search + (semantic-tag-components (car tags))) + ;; Ok, we are completely encompassed within the first tag + ;; entry, AND that tag has children. This means that change + ;; occured outside of all children, but inside some tag + ;; with children. + (if (or (not (semantic-tag-with-position-p (car list-to-search))) + (> start (semantic-tag-end + (nth (1- (length list-to-search)) + list-to-search))) + (< end (semantic-tag-start (car list-to-search)))) + ;; We have modifications to the definition of this parent + ;; and not between it's children. Clear the search list. + (setq list-to-search nil))) + ;; Search list is nil. + )) + ;; If we have a search list, lets go. Otherwise nothing. + (while (and list-to-search (not found)) + (if (cdr list-to-search) + ;; We end when the start of the CDR is after the end of our + ;; asked change. + (if (< (semantic-tag-start (cadr list-to-search)) end) + (setq list-to-search (cdr list-to-search)) + (setq found t)) + (setq list-to-search nil))) + ;; Return it. If it is nil, there is a logic bug, and we need + ;; to avoid this bit of logic anyway. + list-to-search + )) + +(defun semantic-edits-change-over-tags (change) + "Return a cache list of tags surrounding a CHANGE encompassing tags. +CHANGE must not only include all overlapped tags (excepting possible +parent tags) in their entirety. In this case, the change may be deleting +or moving whole tags. +The return value is a vector. +Cell 0 is a list of all tags completely encompassed in change. +Cell 1 is the cons cell into a master parser cache starting with +the cell which occurs BEFORE the first position of CHANGE. +Cell 2 is the parent of cell 1, or nil for the buffer cache. +This function returns nil if any tag covered by change is not +completely encompassed. +See `semantic-edits-change-leaf-tag' for details on parents." + (let* ((start (semantic-edits-os change)) + (end (semantic-edits-oe change)) + (tags (nreverse + (semantic-find-tag-by-overlay-in-region + start end))) + (parent nil) + (overlapped-tags nil) + inner-start inner-end + (list-to-search nil)) + ;; By the time this is already called, we know that it is + ;; not a leaf change, nor a between tag change. That leaves + ;; an overlap, and this condition. + + ;; A leaf is always first in this list. + ;; Is the leaf encompassed in this change? + (if (and tags + (>= (semantic-tag-start (car tags)) start) + (<= (semantic-tag-end (car tags)) end)) + (progn + ;; We encompass one whole change. + (setq overlapped-tags (list (car tags)) + inner-start (semantic-tag-start (car tags)) + inner-end (semantic-tag-end (car tags)) + tags (cdr tags)) + ;; Keep looping while tags are inside the change. + (while (and tags + (>= (semantic-tag-start (car tags)) start) + (<= (semantic-tag-end (car tags)) end)) + + ;; Check if this new all-encompassing tag is a parent + ;; of that which went before. Only check end because + ;; we know that start is less than inner-start since + ;; tags was sorted on that. + (if (> (semantic-tag-end (car tags)) inner-end) + ;; This is a parent. Drop the children found + ;; so far. + (setq overlapped-tags (list (car tags)) + inner-start (semantic-tag-start (car tags)) + inner-end (semantic-tag-end (car tags)) + ) + ;; It is not a parent encompassing tag + (setq overlapped-tags (cons (car tags) + overlapped-tags) + inner-start (semantic-tag-start (car tags)))) + (setq tags (cdr tags))) + (if (not tags) + ;; There are no tags left, and all tags originally + ;; found are encompassed by the change. Setup our list + ;; from the cache + (setq list-to-search semantic--buffer-cache);; We have a tag ouside the list. Check for + ;; We know we have a parent because it would + ;; completely cover the change. A tag can only + ;; do that if it is a parent after we get here. + (when (and tags + (< (semantic-tag-start (car tags)) start) + (> (semantic-tag-end (car tags)) end)) + ;; We have a parent. Stuff in the search list. + (setq parent (car tags) + list-to-search (semantic-tag-components parent)) + ;; If the first of TAGS is a parent (see above) + ;; then clear out the list. All other tags in + ;; here must therefore be parents of the car. + (setq tags nil) + ;; One last check, If start is before the first + ;; tag or after the last, we may have overlap into + ;; the characters that make up the definition of + ;; the tag we are parsing. + (when (or (semantic-tag-with-position-p (car list-to-search)) + (< start (semantic-tag-start + (car list-to-search))) + (> end (semantic-tag-end + (nth (1- (length list-to-search)) + list-to-search)))) + ;; We have a problem + (setq list-to-search nil + parent nil)))) + + (when list-to-search + + ;; Ok, return the vector only if all TAGS are + ;; confirmed as the lineage of `overlapped-tags' + ;; which must have a value by now. + + ;; Loop over the search list to find the preceeding CDR. + ;; Fortunatly, (car overlapped-tags) happens to be + ;; the first tag positionally. + (let ((tokstart (semantic-tag-start (car overlapped-tags)))) + (while (and list-to-search + ;; Assume always (car (cdr list-to-search)). + ;; A thrown error will be captured nicely, but + ;; that case shouldn't happen. + + ;; We end when the start of the CDR is after the + ;; end of our asked change. + (cdr list-to-search) + (< (semantic-tag-start (car (cdr list-to-search))) + tokstart) + (setq list-to-search (cdr list-to-search))))) + ;; Create the return vector + (vector overlapped-tags + list-to-search + parent) + )) + nil))) + +;;; Default Incremental Parser +;; +;; Logic about how to group changes for effective reparsing and splicing. + +(defun semantic-parse-changes-failed (&rest args) + "Signal that Semantic failed to parse changes. +That is, display a message by passing all ARGS to `format', then throw +a 'semantic-parse-changes-failed exception with value t." + (when semantic-edits-verbose-flag + (message "Semantic parse changes failed: %S" + (apply 'format args))) + (throw 'semantic-parse-changes-failed t)) + +(defsubst semantic-edits-incremental-fail () + "When the incremental parser fails, we mark that we need a full reparse." + ;;(debug) + (semantic-parse-tree-set-needs-rebuild) + (when semantic-edits-verbose-flag + (message "Force full reparse (%s)" + (buffer-name (current-buffer)))) + (run-hooks 'semantic-edits-incremental-reparse-failed-hooks)) + +(defun semantic-edits-incremental-parser () + "Incrementally reparse the current buffer. +Incremental parser allows semantic to only reparse those sections of +the buffer that have changed. This function depends on +`semantic-edits-change-function-handle-changes' setting up change +overlays in the current buffer. Those overlays are analyzed against +the semantic cache to see what needs to be changed." + (let ((changed-tags + ;; Don't use `semantic-safe' here to explicitly catch errors + ;; and reset the parse tree. + (catch 'semantic-parse-changes-failed + (if debug-on-error + (semantic-edits-incremental-parser-1) + (condition-case err + (semantic-edits-incremental-parser-1) + (error + (message "incremental parser error: %S" + (error-message-string err)) + t)))))) + (when (eq changed-tags t) + ;; Force a full reparse. + (semantic-edits-incremental-fail) + (setq changed-tags nil)) + changed-tags)) + +(defmacro semantic-edits-assert-valid-region () + "Asert that parse-start and parse-end are sorted correctly." +;;; (if (> parse-start parse-end) +;;; (error "Bug is %s !> %d! Buff min/max = [ %d %d ]" +;;; parse-start parse-end +;;; (point-min) (point-max))) + ) + +(defun semantic-edits-incremental-parser-1 () + "Incrementally reparse the current buffer. +Return the list of tags that changed. +If the incremental parse fails, throw a 'semantic-parse-changes-failed +exception with value t, that can be caught to schedule a full reparse. +This function is for internal use by `semantic-edits-incremental-parser'." + (let* ((changed-tags nil) + (debug-on-quit t) ; try to find this annoying bug! + (changes (semantic-changes-in-region + (point-min) (point-max))) + (tags nil) ;tags found at changes + (newf-tags nil) ;newfound tags in change + (parse-start nil) ;location to start parsing + (parse-end nil) ;location to end parsing + (parent-tag nil) ;parent of the cache list. + (cache-list nil) ;list of children within which + ;we incrementally reparse. + (reparse-symbol nil) ;The ruled we start at for reparse. + (change-group nil) ;changes grouped in this reparse + (last-cond nil) ;track the last case used. + ;query this when debugging to find + ;source of bugs. + ) + (or changes + ;; If we were called, and there are no changes, then we + ;; don't know what to do. Force a full reparse. + (semantic-parse-changes-failed "Don't know what to do")) + ;; Else, we have some changes. Loop over them attempting to + ;; patch things up. + (while changes + ;; Calculate the reparse boundary. + ;; We want to take some set of changes, and group them + ;; together into a small change group. One change forces + ;; a reparse of a larger region (the size of some set of + ;; tags it encompases.) It may contain several tags. + ;; That region may have other changes in it (several small + ;; changes in one function, for example.) + ;; Optimize for the simple cases here, but try to handle + ;; complex ones too. + + (while (and changes ; we still have changes + (or (not parse-start) + ;; Below, if the change we are looking at + ;; is not the first change for this + ;; iteration, and it starts before the end + ;; of current parse region, then it is + ;; encompased within the bounds of tags + ;; modified by the previous iteration's + ;; change. + (< (semantic-overlay-start (car changes)) + parse-end))) + + ;; REMOVE LATER + (if (eq (car changes) (car change-group)) + (semantic-parse-changes-failed + "Possible infinite loop detected")) + + ;; Store this change in this change group. + (setq change-group (cons (car changes) change-group)) + + (cond + ;; Is this is a new parse group? + ((not parse-start) + (setq last-cond "new group") + (let (tmp) + (cond + +;;;; Are we encompassed all in one tag? + ((setq tmp (semantic-edits-change-leaf-tag (car changes))) + (setq last-cond "Encompassed in tag") + (setq tags (list tmp) + parse-start (semantic-tag-start tmp) + parse-end (semantic-tag-end tmp) + ) + (semantic-edits-assert-valid-region)) + +;;;; Did the change occur between some tags? + ((setq cache-list (semantic-edits-change-between-tags + (car changes))) + (setq last-cond "Between and not overlapping tags") + ;; The CAR of cache-list is the tag just before + ;; our change, but wasn't modified. Hmmm. + ;; Bound our reparse between these two tags + (setq tags nil + parent-tag + (car (semantic-find-tag-by-overlay + parse-start))) + (cond + ;; A change at the beginning of the buffer. + ;; Feb 06 - + ;; IDed when the first cache-list tag is after + ;; our change, meaning there is nothing before + ;; the chnge. + ((> (semantic-tag-start (car cache-list)) + (semantic-overlay-end (car changes))) + (setq last-cond "Beginning of buffer") + (setq parse-start + ;; Don't worry about parents since + ;; there there would be an exact + ;; match in the tag list otherwise + ;; and the routine would fail. + (point-min) + parse-end + (semantic-tag-start (car cache-list))) + (semantic-edits-assert-valid-region) + ) + ;; A change stuck on the first surrounding tag. + ((= (semantic-tag-end (car cache-list)) + (semantic-overlay-start (car changes))) + (setq last-cond "Beginning of Tag") + ;; Reparse that first tag. + (setq parse-start + (semantic-tag-start (car cache-list)) + parse-end + (semantic-overlay-end (car changes)) + tags + (list (car cache-list))) + (semantic-edits-assert-valid-region) + ) + ;; A change at the end of the buffer. + ((not (car (cdr cache-list))) + (setq last-cond "End of buffer") + (setq parse-start (semantic-tag-end + (car cache-list)) + parse-end (point-max)) + (semantic-edits-assert-valid-region) + ) + (t + (setq last-cond "Default") + (setq parse-start + (semantic-tag-end (car cache-list)) + parse-end + (semantic-tag-start (car (cdr cache-list))) + ) + (semantic-edits-assert-valid-region)))) + +;;;; Did the change completely overlap some number of tags? + ((setq tmp (semantic-edits-change-over-tags + (car changes))) + (setq last-cond "Overlap multiple tags") + ;; Extract the information + (setq tags (aref tmp 0) + cache-list (aref tmp 1) + parent-tag (aref tmp 2)) + ;; We can calculate parse begin/end by checking + ;; out what is in TAGS. The one near start is + ;; always first. Make sure the reprase includes + ;; the `whitespace' around the snarfed tags. + ;; Since cache-list is positioned properly, use it + ;; to find that boundary. + (if (eq (car tags) (car cache-list)) + ;; Beginning of the buffer! + (let ((end-marker (nth (length tags) + cache-list))) + (setq parse-start (point-min)) + (if end-marker + (setq parse-end + (semantic-tag-start end-marker)) + (setq parse-end (semantic-overlay-end + (car changes)))) + (semantic-edits-assert-valid-region) + ) + ;; Middle of the buffer. + (setq parse-start + (semantic-tag-end (car cache-list))) + ;; For the end, we need to scoot down some + ;; number of tags. We 1+ the length of tags + ;; because we want to skip the first tag + ;; (remove 1-) then want the tag after the end + ;; of the list (1+) + (let ((end-marker (nth (1+ (length tags)) cache-list))) + (if end-marker + (setq parse-end (semantic-tag-start end-marker)) + ;; No marker. It is the last tag in our + ;; list of tags. Only possible if END + ;; already matches the end of that tag. + (setq parse-end + (semantic-overlay-end (car changes))))) + (semantic-edits-assert-valid-region) + )) + +;;;; Unhandled case. + ;; Throw error, and force full reparse. + ((semantic-parse-changes-failed "Unhandled change group"))) + )) + ;; Is this change inside the previous parse group? + ;; We already checked start. + ((< (semantic-overlay-end (car changes)) parse-end) + (setq last-cond "in bounds") + nil) + ;; This change extends the current parse group. + ;; Find any new tags, and see how to append them. + ((semantic-parse-changes-failed + (setq last-cond "overlap boundary") + "Unhandled secondary change overlapping boundary")) + ) + ;; Prepare for the next iteration. + (setq changes (cdr changes))) + + ;; By the time we get here, all TAGS are children of + ;; some parent. They should all have the same start symbol + ;; since that is how the multi-tag parser works. Grab + ;; the reparse symbol from the first of the returned tags. + ;; + ;; Feb '06 - If repase-symbol is nil, then they are top level + ;; tags. (I'm guessing.) Is this right? + (setq reparse-symbol + (semantic--tag-get-property (car (or tags cache-list)) + 'reparse-symbol)) + ;; Find a parent if not provided. + (and (not parent-tag) tags + (setq parent-tag + (semantic-find-tag-parent-by-overlay + (car tags)))) + ;; We can do the same trick for our parent and resulting + ;; cache list. + (unless cache-list + (if parent-tag + (setq cache-list + ;; We need to get all children in case we happen + ;; to have a mix of positioned and non-positioned + ;; children. + (semantic-tag-components parent-tag)) + ;; Else, all the tags since there is no parent. + ;; It sucks to have to use the full buffer cache in + ;; this case because it can be big. Failure to provide + ;; however results in a crash. + (setq cache-list semantic--buffer-cache) + )) + ;; Use the boundary to calculate the new tags found. + (setq newf-tags (semantic-parse-region + parse-start parse-end reparse-symbol)) + ;; Make sure all these tags are given overlays. + ;; They have already been cooked by the parser and just + ;; need the overlays. + (let ((tmp newf-tags)) + (while tmp + (semantic--tag-link-to-buffer (car tmp)) + (setq tmp (cdr tmp)))) + + ;; See how this change lays out. + (cond + +;;;; Whitespace change + ((and (not tags) (not newf-tags)) + ;; A change that occured outside of any existing tags + ;; and there are no new tags to replace it. + (when semantic-edits-verbose-flag + (message "White space changes")) + nil + ) + +;;;; New tags in old whitespace area. + ((and (not tags) newf-tags) + ;; A change occured outside existing tags which added + ;; a new tag. We need to splice these tags back + ;; into the cache at the right place. + (semantic-edits-splice-insert newf-tags parent-tag cache-list) + + (setq changed-tags + (append newf-tags changed-tags)) + + (when semantic-edits-verbose-flag + (message "Inserted tags: (%s)" + (semantic-format-tag-name (car newf-tags)))) + ) + +;;;; Old tags removed + ((and tags (not newf-tags)) + ;; A change occured where pre-existing tags were + ;; deleted! Remove the tag from the cache. + (semantic-edits-splice-remove tags parent-tag cache-list) + + (setq changed-tags + (append tags changed-tags)) + + (when semantic-edits-verbose-flag + (message "Deleted tags: (%s)" + (semantic-format-tag-name (car tags)))) + ) + +;;;; One tag was updated. + ((and (= (length tags) 1) (= (length newf-tags) 1)) + ;; One old tag was modified, and it is replaced by + ;; One newfound tag. Splice the new tag into the + ;; position of the old tag. + ;; Do the splice. + (semantic-edits-splice-replace (car tags) (car newf-tags)) + ;; Add this tag to our list of changed toksns + (setq changed-tags (cons (car tags) changed-tags)) + ;; Debug + (when semantic-edits-verbose-flag + (message "Update Tag Table: %s" + (semantic-format-tag-name (car tags) nil t))) + ;; Flush change regardless of above if statement. + ) + +;;;; Some unhandled case. + ((semantic-parse-changes-failed "Don't know what to do"))) + + ;; We got this far, and we didn't flag a full reparse. + ;; Clear out this change group. + (while change-group + (semantic-edits-flush-change (car change-group)) + (setq change-group (cdr change-group))) + + ;; Don't increment change here because an earlier loop + ;; created change-groups. + (setq parse-start nil) + ) + ;; Mark that we are done with this glop + (semantic-parse-tree-set-up-to-date) + ;; Return the list of tags that changed. The caller will + ;; use this information to call hooks which can fix themselves. + changed-tags)) + +;; Make it the default changes parser +(defalias 'semantic-parse-changes-default + 'semantic-edits-incremental-parser) + +;;; Cache Splicing +;; +;; The incremental parser depends on the ability to parse up sections +;; of the file, and splice the results back into the cache. There are +;; three types of splices. A REPLACE, an ADD, and a REMOVE. REPLACE +;; is one of the simpler cases, as the starting cons cell representing +;; the old tag can be used to auto-splice in. ADD and REMOVE +;; require scanning the cache to find the correct location so that the +;; list can be fiddled. +(defun semantic-edits-splice-remove (oldtags parent cachelist) + "Remove OLDTAGS from PARENT's CACHELIST. +OLDTAGS are tags in the currenet buffer, preferably linked +together also in CACHELIST. +PARENT is the parent tag containing OLDTAGS. +CACHELIST should be the children from PARENT, but may be +pre-positioned to a convenient location." + (let* ((first (car oldtags)) + (last (nth (1- (length oldtags)) oldtags)) + (chil (if parent + (semantic-tag-components parent) + semantic--buffer-cache)) + (cachestart cachelist) + (cacheend nil) + ) + ;; First in child list? + (if (eq first (car chil)) + ;; First tags in the cache are being deleted. + (progn + (when semantic-edits-verbose-flag + (message "To Remove First Tag: (%s)" + (semantic-format-tag-name first))) + ;; Find the last tag + (setq cacheend chil) + (while (and cacheend (not (eq last (car cacheend)))) + (setq cacheend (cdr cacheend))) + ;; The splicable part is after cacheend.. so move cacheend + ;; one more tag. + (setq cacheend (cdr cacheend)) + ;; Splice the found end tag into the cons cell + ;; owned by the current top child. + (setcar chil (car cacheend)) + (setcdr chil (cdr cacheend)) + (when (not cacheend) + ;; No cacheend.. then the whole system is empty. + ;; The best way to deal with that is to do a full + ;; reparse + (semantic-parse-changes-failed "Splice-remove failed. Empty buffer?") + )) + (message "To Remove Middle Tag: (%s)" + (semantic-format-tag-name first))) + ;; Find in the cache the preceeding tag + (while (and cachestart (not (eq first (car (cdr cachestart))))) + (setq cachestart (cdr cachestart))) + ;; Find the last tag + (setq cacheend cachestart) + (while (and cacheend (not (eq last (car cacheend)))) + (setq cacheend (cdr cacheend))) + ;; Splice the end position into the start position. + ;; If there is no start, then this whole section is probably + ;; gone. + (if cachestart + (setcdr cachestart (cdr cacheend)) + (semantic-parse-changes-failed "Splice-remove failed.")) + + ;; Remove old overlays of these deleted tags + (while oldtags + (semantic--tag-unlink-from-buffer (car oldtags)) + (setq oldtags (cdr oldtags))) + )) + +(defun semantic-edits-splice-insert (newtags parent cachelist) + "Insert NEWTAGS into PARENT using CACHELIST. +PARENT could be nil, in which case CACHLIST is the buffer cache +which must be updated. +CACHELIST must be searched to find where NEWTAGS are to be inserted. +The positions of NEWTAGS must be synchronized with those in +CACHELIST for this to work. Some routines pre-position CACHLIST at a +convenient location, so use that." + (let* ((start (semantic-tag-start (car newtags))) + (newtagendcell (nthcdr (1- (length newtags)) newtags)) + (end (semantic-tag-end (car newtagendcell))) + ) + (if (> (semantic-tag-start (car cachelist)) start) + ;; We are at the beginning. + (let* ((pc (if parent + (semantic-tag-components parent) + semantic--buffer-cache)) + (nc (cons (car pc) (cdr pc))) ; new cons cell. + ) + ;; Splice the new cache cons cell onto the end of our list. + (setcdr newtagendcell nc) + ;; Set our list into parent. + (setcar pc (car newtags)) + (setcdr pc (cdr newtags))) + ;; We are at the end, or in the middle. Find our match first. + (while (and (cdr cachelist) + (> end (semantic-tag-start (car (cdr cachelist))))) + (setq cachelist (cdr cachelist))) + ;; Now splice into the list! + (setcdr newtagendcell (cdr cachelist)) + (setcdr cachelist newtags)))) + +(defun semantic-edits-splice-replace (oldtag newtag) + "Replace OLDTAG with NEWTAG in the current cache. +Do this by recycling OLDTAG's first CONS cell. This effectivly +causes the new tag to completely replace the old one. +Make sure that all information in the overlay is transferred. +It is presumed that OLDTAG and NEWTAG are both cooked. +When this routine returns, OLDTAG is raw, and the data will be +lost if not transferred into NEWTAG." + (let* ((oo (semantic-tag-overlay oldtag)) + (o (semantic-tag-overlay newtag)) + (oo-props (semantic-overlay-properties oo))) + (while oo-props + (semantic-overlay-put o (car oo-props) (car (cdr oo-props))) + (setq oo-props (cdr (cdr oo-props))) + ) + ;; Free the old overlay(s) + (semantic--tag-unlink-from-buffer oldtag) + ;; Recover properties + (semantic--tag-copy-properties oldtag newtag) + ;; Splice into the main list. + (setcdr oldtag (cdr newtag)) + (setcar oldtag (car newtag)) + ;; This important bit is because the CONS cell representing + ;; OLDTAG is now pointing to NEWTAG, but the NEWTAG + ;; cell is about to be abandoned. Here we update our overlay + ;; to point at the updated state of the world. + (semantic-overlay-put o 'semantic oldtag) + )) + +;;; Setup incremental parser +;; +(add-hook 'semantic-change-hooks + #'semantic-edits-change-function-handle-changes) +(add-hook 'semantic-before-toplevel-cache-flush-hook + #'semantic-edits-flush-changes) + +(provide 'semantic/edit) + +;;; semantic-edit.el ends here diff --git a/lisp/cedet/semantic/html.el b/lisp/cedet/semantic/html.el new file mode 100644 index 00000000000..05d1b2b7d8f --- /dev/null +++ b/lisp/cedet/semantic/html.el @@ -0,0 +1,262 @@ +;;; html.el --- Semantic details for html files + +;;; Copyright (C) 2004, 2005, 2007, 2008 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; 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 . + +;;; 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