--- /dev/null
+;;; semantic/decorate/include.el --- Decoration modes for include statements
+
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Highlight any include that is in a state the user may care about.
+;; The basic idea is to have the state be highly visible so users will
+;; as 'what is this?" and get the info they need to fix problems that
+;; are otherwises transparent when trying to get smart completion
+;; working.
+
+(require 'semantic/decorate/mode)
+(require 'semantic/db)
+(require 'semantic/db-ref)
+(require 'semantic/db-find)
+
+(eval-when-compile
+ (require 'semantic/find))
+
+(defvar semantic-dependency-system-include-path)
+
+;;; Code:
+
+;;; FACES AND KEYMAPS
+(defvar semantic-decoratiton-mouse-3 (if (featurep 'xemacs) [ button3 ] [ mouse-3 ])
+ "The keybinding lisp object to use for binding the right mouse button.")
+
+;;; Includes that that are in a happy state!
+;;
+(defface semantic-decoration-on-includes
+ nil
+ "*Overlay Face used on includes that are not in some other state.
+Used by the decoration style: `semantic-decoration-on-includes'."
+ :group 'semantic-faces)
+
+(defvar semantic-decoration-on-include-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km semantic-decoratiton-mouse-3 'semantic-decoration-include-menu)
+ km)
+ "Keymap used on includes.")
+
+
+(defvar semantic-decoration-on-include-menu nil
+ "Menu used for include headers.")
+
+(easy-menu-define
+ semantic-decoration-on-include-menu
+ semantic-decoration-on-include-map
+ "Include Menu"
+ (list
+ "Include"
+ (semantic-menu-item
+ ["What Is This?" semantic-decoration-include-describe
+ :active t
+ :help "Describe why this include has been marked this way." ])
+ (semantic-menu-item
+ ["Visit This Include" semantic-decoration-include-visit
+ :active t
+ :help "Visit this include file." ])
+ "---"
+ (semantic-menu-item
+ ["Summarize includes current buffer" semantic-decoration-all-include-summary
+ :active t
+ :help "Show a summary for the current buffer containing this include." ])
+ (semantic-menu-item
+ ["List found includes (load unparsed)" semanticdb-find-test-translate-path
+ :active t
+ :help "List all includes found for this file, and parse unparsed files." ])
+ (semantic-menu-item
+ ["List found includes (no loading)" semanticdb-find-test-translate-path-no-loading
+ :active t
+ :help "List all includes found for this file, do not parse unparsed files." ])
+ (semantic-menu-item
+ ["List all unknown includes" semanticdb-find-adebug-lost-includes
+ :active t
+ :help "Show a list of all includes semantic cannot find for this file." ])
+ "---"
+ (semantic-menu-item
+ ["Customize System Include Path" semantic-customize-system-include-path
+ :active (get 'semantic-dependency-system-include-path major-mode)
+ :help "Run customize for the system include path for this major mode." ])
+ (semantic-menu-item
+ ["Add a System Include Path" semantic-add-system-include
+ :active t
+ :help "Add an include path for this session." ])
+ (semantic-menu-item
+ ["Remove a System Include Path" semantic-remove-system-include
+ :active t
+ :help "Add an include path for this session." ])
+ ;;["" semantic-decoration-include-
+ ;; :active t
+ ;; :help "" ]
+ ))
+
+;;; Unknown Includes!
+;;
+(defface semantic-decoration-on-unknown-includes
+ '((((class color) (background dark))
+ (:background "#900000"))
+ (((class color) (background light))
+ (:background "#ff5050")))
+ "*Face used to show includes that cannot be found.
+Used by the decoration style: `semantic-decoration-on-unknown-includes'."
+ :group 'semantic-faces)
+
+(defvar semantic-decoration-on-unknown-include-map
+ (let ((km (make-sparse-keymap)))
+ ;(define-key km [ mouse-2 ] 'semantic-decoration-unknown-include-describe)
+ (define-key km semantic-decoratiton-mouse-3 'semantic-decoration-unknown-include-menu)
+ km)
+ "Keymap used on unparsed includes.")
+
+(defvar semantic-decoration-on-unknown-include-menu nil
+ "Menu used for unparsed include headers.")
+
+(easy-menu-define
+ semantic-decoration-on-unknown-include-menu
+ semantic-decoration-on-unknown-include-map
+ "Unknown Include Menu"
+ (list
+ "Unknown Include"
+ (semantic-menu-item
+ ["What Is This?" semantic-decoration-unknown-include-describe
+ :active t
+ :help "Describe why this include has been marked this way." ])
+ (semantic-menu-item
+ ["List all unknown includes" semanticdb-find-adebug-lost-includes
+ :active t
+ :help "Show a list of all includes semantic cannot find for this file." ])
+ "---"
+ (semantic-menu-item
+ ["Summarize includes current buffer" semantic-decoration-all-include-summary
+ :active t
+ :help "Show a summary for the current buffer containing this include." ])
+ (semantic-menu-item
+ ["List found includes (load unparsed)" semanticdb-find-test-translate-path
+ :active t
+ :help "List all includes found for this file, and parse unparsed files." ])
+ (semantic-menu-item
+ ["List found includes (no loading)" semanticdb-find-test-translate-path-no-loading
+ :active t
+ :help "List all includes found for this file, do not parse unparsed files." ])
+ "---"
+ (semantic-menu-item
+ ["Customize System Include Path" semantic-customize-system-include-path
+ :active (get 'semantic-dependency-system-include-path major-mode)
+ :help "Run customize for the system include path for this major mode." ])
+ (semantic-menu-item
+ ["Add a System Include Path" semantic-add-system-include
+ :active t
+ :help "Add an include path for this session." ])
+ (semantic-menu-item
+ ["Remove a System Include Path" semantic-remove-system-include
+ :active t
+ :help "Add an include path for this session." ])
+ ))
+
+;;; Includes that need to be parsed.
+;;
+(defface semantic-decoration-on-unparsed-includes
+ '((((class color) (background dark))
+ (:background "#555500"))
+ (((class color) (background light))
+ (:background "#ffff55")))
+ "*Face used to show includes that have not yet been parsed.
+Used by the decoration style: `semantic-decoration-on-unparsed-includes'."
+ :group 'semantic-faces)
+
+(defvar semantic-decoration-on-unparsed-include-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km semantic-decoratiton-mouse-3 'semantic-decoration-unparsed-include-menu)
+ km)
+ "Keymap used on unparsed includes.")
+
+
+(defvar semantic-decoration-on-unparsed-include-menu nil
+ "Menu used for unparsed include headers.")
+
+(easy-menu-define
+ semantic-decoration-on-unparsed-include-menu
+ semantic-decoration-on-unparsed-include-map
+ "Unparsed Include Menu"
+ (list
+ "Unparsed Include"
+ (semantic-menu-item
+ ["What Is This?" semantic-decoration-unparsed-include-describe
+ :active t
+ :help "Describe why this include has been marked this way." ])
+ (semantic-menu-item
+ ["Visit This Include" semantic-decoration-include-visit
+ :active t
+ :help "Visit this include file so that header file's tags can be used." ])
+ (semantic-menu-item
+ ["Parse This Include" semantic-decoration-unparsed-include-parse-include
+ :active t
+ :help "Parse this include file so that header file's tags can be used." ])
+ (semantic-menu-item
+ ["Parse All Includes" semantic-decoration-unparsed-include-parse-all-includes
+ :active t
+ :help "Parse all the includes so the contents can be used." ])
+ "---"
+ (semantic-menu-item
+ ["Summarize includes current buffer" semantic-decoration-all-include-summary
+ :active t
+ :help "Show a summary for the current buffer containing this include." ])
+ (semantic-menu-item
+ ["List found includes (load unparsed)" semanticdb-find-test-translate-path
+ :active t
+ :help "List all includes found for this file, and parse unparsed files." ])
+ (semantic-menu-item
+ ["List found includes (no loading)" semanticdb-find-test-translate-path-no-loading
+ :active t
+ :help "List all includes found for this file, do not parse unparsed files." ])
+ (semantic-menu-item
+ ["List all unknown includes" semanticdb-find-adebug-lost-includes
+ :active t
+ :help "Show a list of all includes semantic cannot find for this file." ])
+ "---"
+ (semantic-menu-item
+ ["Customize System Include Path" semantic-customize-system-include-path
+ :active (get 'semantic-dependency-system-include-path major-mode)
+ :help "Run customize for the system include path for this major mode." ])
+ (semantic-menu-item
+ ["Add a System Include Path" semantic-add-system-include
+ :active t
+ :help "Add an include path for this session." ])
+ (semantic-menu-item
+ ["Remove a System Include Path" semantic-remove-system-include
+ :active t
+ :help "Add an include path for this session." ])
+ ;;["" semantic-decoration-unparsed-include-
+ ;; :active t
+ ;; :help "" ]
+ ))
+
+\f
+;;; MODES
+
+;;; Include statement Decorate Mode
+;;
+;; This mode handles the three states of an include statements
+;;
+(define-semantic-decoration-style semantic-decoration-on-includes
+ "Highlight class members that are includes.
+This mode provides a nice context menu on the include statements."
+ :enabled t)
+
+(defun semantic-decoration-on-includes-p-default (tag)
+ "Return non-nil if TAG has is an includes that can't be found."
+ (semantic-tag-of-class-p tag 'include))
+
+(defun semantic-decoration-on-includes-highlight-default (tag)
+ "Highlight the include TAG to show that semantic can't find it."
+ (let* ((file (semantic-dependency-tag-file tag))
+ (table (when file
+ (semanticdb-file-table-object file t)))
+ (face nil)
+ (map nil)
+ )
+ (cond
+ ((not file)
+ ;; Cannot find this header.
+ (setq face 'semantic-decoration-on-unknown-includes
+ map semantic-decoration-on-unknown-include-map)
+ )
+ ((and table (number-or-marker-p (oref table pointmax)))
+ ;; A found and parsed file.
+ (setq face 'semantic-decoration-on-includes
+ map semantic-decoration-on-include-map)
+ )
+ (t
+ ;; An unparsed file.
+ (setq face 'semantic-decoration-on-unparsed-includes
+ map semantic-decoration-on-unparsed-include-map)
+ (when table
+ ;; Set ourselves up for synchronization
+ (semanticdb-cache-get
+ table 'semantic-decoration-unparsed-include-cache)
+ ;; Add a dependancy.
+ (let ((table semanticdb-current-table))
+ (semanticdb-add-reference table tag))
+ )
+ ))
+
+ (let ((ol (semantic-decorate-tag tag
+ (semantic-tag-start tag)
+ (semantic-tag-end tag)
+ face))
+ )
+ (semantic-overlay-put ol 'mouse-face 'highlight)
+ (semantic-overlay-put ol 'keymap map)
+ (semantic-overlay-put ol 'help-echo
+ "Header File : mouse-3 - Context menu")
+ )))
+
+;;; Regular Include Functions
+;;
+(defun semantic-decoration-include-describe ()
+ "Describe what unparsed includes are in the current buffer.
+Argument EVENT is the mouse clicked event."
+ (interactive)
+ (let* ((tag (or (semantic-current-tag)
+ (error "No tag under point")))
+ (file (semantic-dependency-tag-file tag))
+ (table (when file
+ (semanticdb-file-table-object file t))))
+ (with-output-to-temp-buffer (help-buffer) ; "*Help*"
+ (help-setup-xref (list #'semantic-decoration-include-describe)
+ (interactive-p))
+ (princ "Include File: ")
+ (princ (semantic-format-tag-name tag nil t))
+ (princ "\n")
+ (princ "This include file was found at:\n ")
+ (princ (semantic-dependency-tag-file tag))
+ (princ "\n\n")
+ (princ "Semantic knows where this include file is, and has parsed
+its contents.
+
+")
+ (let ((inc (semantic-find-tags-by-class 'include table))
+ (ok 0)
+ (unknown 0)
+ (unparsed 0)
+ (all 0))
+ (dolist (i inc)
+ (let* ((fileinner (semantic-dependency-tag-file i))
+ )
+ (cond ((not fileinner)
+ (setq unknown (1+ unknown)))
+ ((number-or-marker-p (oref table pointmax))
+ (setq ok (1+ ok)))
+ (t
+ (setq unparsed (1+ unparsed))))))
+ (setq all (+ ok unknown unparsed))
+ (if (= 0 all)
+ (princ "There are no other includes in this file.\n")
+ (princ (format "There are %d more includes in this file.\n"
+ all))
+ (princ (format " Unknown Includes: %d\n" unknown))
+ (princ (format " Unparsed Includes: %d\n" unparsed))
+ (princ (format " Parsed Includes: %d\n" ok)))
+ )
+ ;; Get the semanticdb statement, and display it's contents.
+ (princ "\nDetails for header file...\n")
+ (princ "\nMajor Mode: ")
+ (princ (oref table :major-mode))
+ (princ "\nTags: ")
+ (princ (format "%s entries" (length (oref table :tags))))
+ (princ "\nFile Size: ")
+ (princ (format "%s chars" (oref table :pointmax)))
+ (princ "\nSave State: ")
+ (cond ((oref table dirty)
+ (princ "Table needs to be saved."))
+ (t
+ (princ "Table is saved on disk."))
+ )
+ (princ "\nExternal References:")
+ (dolist (r (oref table db-refs))
+ (princ "\n ")
+ (princ (oref r file)))
+ )))
+
+;;;;###autoload
+(defun semantic-decoration-include-visit ()
+ "Visit the included file at point."
+ (interactive)
+ (let ((tag (semantic-current-tag)))
+ (unless (eq (semantic-tag-class tag) 'include)
+ (error "Point is not on an include tag"))
+ (let ((file (semantic-dependency-tag-file tag)))
+ (cond
+ ((or (not file) (not (file-exists-p file)))
+ (error "Could not location include %s"
+ (semantic-tag-name tag)))
+ ((get-file-buffer file)
+ (switch-to-buffer (get-file-buffer file)))
+ ((stringp file)
+ (find-file file))
+ ))))
+
+(defun semantic-decoration-include-menu (event)
+ "Popup a menu that can help a user understand unparsed includes.
+Argument EVENT describes the event that caused this function to be called."
+ (interactive "e")
+ (let* ((startwin (selected-window))
+ (win (semantic-event-window event))
+ )
+ (select-window win t)
+ (save-excursion
+ ;(goto-char (window-start win))
+ (mouse-set-point event)
+ (sit-for 0)
+ (semantic-popup-menu semantic-decoration-on-include-menu)
+ )
+ (select-window startwin)))
+
+\f
+;;; Unknown Include functions
+;;
+(defun semantic-decoration-unknown-include-describe ()
+ "Describe what unknown includes are in the current buffer.
+Argument EVENT is the mouse clicked event."
+ (interactive)
+ (let ((tag (semantic-current-tag))
+ (mm major-mode))
+ (with-output-to-temp-buffer (help-buffer) ; "*Help*"
+ (help-setup-xref (list #'semantic-decoration-unknown-include-describe)
+ (interactive-p))
+ (princ "Include File: ")
+ (princ (semantic-format-tag-name tag nil t))
+ (princ "\n\n")
+ (princ "This header file has been marked \"Unknown\".
+This means that Semantic has not been able to locate this file on disk.
+
+When Semantic cannot find an include file, this means that the
+idle summary mode and idle completion modes cannot use the contents of
+that file to provide coding assistance.
+
+If this is a system header and you want it excluded from Semantic's
+searches (which may be desirable for speed reasons) then you can
+safely ignore this state.
+
+If this is a system header, and you want to include it in Semantic's
+searches, then you will need to use:
+
+M-x semantic-add-system-include RET /path/to/includes RET
+
+or, in your .emacs file do:
+
+ (semantic-add-system-include \"/path/to/include\" '")
+ (princ (symbol-name mm))
+ (princ ")
+
+to add the path to Semantic's search.
+
+If this is an include file that belongs to your project, then you may
+need to update `semanticdb-project-roots' or better yet, use `ede'
+to manage your project. See the ede manual for projects that will
+wrap existing project code for Semantic's benifit.
+")
+
+ (when (or (eq mm 'c++-mode) (eq mm 'c-mode))
+ (princ "
+For C/C++ includes located within a a project, you can use a special
+EDE project that will wrap an existing build system. You can do that
+like this in your .emacs file:
+
+ (ede-cpp-root-project \"NAME\" :file \"FILENAME\" :locate-fcn 'MYFCN)
+
+See the CEDET manual, the EDE manual, or the commentary in
+ede-cpp-root.el for more.
+
+If you think this header tag is marked in error, you may need to do:
+
+C-u M-x bovinate RET
+
+to refresh the tags in this buffer, and recalculate the state."))
+
+ (princ "
+See the Semantic manual node on SemanticDB for more about search paths.")
+ )))
+
+(defun semantic-decoration-unknown-include-menu (event)
+ "Popup a menu that can help a user understand unparsed includes.
+Argument EVENT describes the event that caused this function to be called."
+ (interactive "e")
+ (let* ((startwin (selected-window))
+ ;; This line has an issue in XEmacs.
+ (win (semantic-event-window event))
+ )
+ (select-window win t)
+ (save-excursion
+ ;(goto-char (window-start win))
+ (mouse-set-point event)
+ (sit-for 0)
+ (semantic-popup-menu semantic-decoration-on-unknown-include-menu)
+ )
+ (select-window startwin)))
+
+\f
+;;; Interactive parts of unparsed includes
+;;
+(defun semantic-decoration-unparsed-include-describe ()
+ "Describe what unparsed includes are in the current buffer.
+Argument EVENT is the mouse clicked event."
+ (interactive)
+ (let ((tag (semantic-current-tag)))
+ (with-output-to-temp-buffer (help-buffer); "*Help*"
+ (help-setup-xref (list #'semantic-decoration-unparsed-include-describe)
+ (interactive-p))
+
+ (princ "Include File: ")
+ (princ (semantic-format-tag-name tag nil t))
+ (princ "\n")
+ (princ "This include file was found at:\n ")
+ (princ (semantic-dependency-tag-file tag))
+ (princ "\n\n")
+ (princ "This header file has been marked \"Unparsed\".
+This means that Semantic has located this header file on disk
+but has not yet opened and parsed this file.
+
+So long as this header file is unparsed, idle summary and
+idle completion will not be able to reference the details in this
+header.
+
+To resolve this, use the context menu to parse this include file,
+or all include files referred to in ")
+ (princ (buffer-name))
+ (princ ".
+This can take a while in large projects.
+
+Alternately, you can call:
+
+M-x semanticdb-find-test-translate-path RET
+
+to search path Semantic uses to perform completion.
+
+
+If you think this header tag is marked in error, you may need to do:
+
+C-u M-x bovinate RET
+
+to refresh the tags in this buffer, and recalculate the state.
+If you find a repeatable case where a header is marked in error,
+report it to cedet-devel@lists.sf.net.") )))
+
+
+(defun semantic-decoration-unparsed-include-menu (event)
+ "Popup a menu that can help a user understand unparsed includes.
+Argument EVENT describes the event that caused this function to be called."
+ (interactive "e")
+ (let* ((startwin (selected-window))
+ (win (semantic-event-window event))
+ )
+ (select-window win t)
+ (save-excursion
+ ;(goto-char (window-start win))
+ (mouse-set-point event)
+ (sit-for 0)
+ (semantic-popup-menu semantic-decoration-on-unparsed-include-menu)
+ )
+ (select-window startwin)))
+
+(defun semantic-decoration-unparsed-include-parse-include ()
+ "Parse the include file the user menu-selected from."
+ (interactive)
+ (let* ((file (semantic-dependency-tag-file (semantic-current-tag))))
+ (semanticdb-file-table-object file)
+ (semantic-decoration-unparsed-include-do-reset)))
+
+
+(defun semantic-decoration-unparsed-include-parse-all-includes ()
+ "Parse the include file the user menu-selected from."
+ (interactive)
+ (semanticdb-find-translate-path nil nil)
+ )
+
+\f
+;;; General Includes Information
+;;
+(defun semantic-decoration-all-include-summary ()
+ "Provide a general summary for the state of all includes."
+ (interactive)
+ (require 'semantic/dep)
+ (let* ((table semanticdb-current-table)
+ (tags (semantic-fetch-tags))
+ (inc (semantic-find-tags-by-class 'include table))
+ )
+ (with-output-to-temp-buffer (help-buffer) ;"*Help*"
+ (help-setup-xref (list #'semantic-decoration-all-include-summary)
+ (interactive-p))
+
+ (princ "Include Summary for File: ")
+ (princ (file-truename (buffer-file-name)))
+ (princ "\n")
+
+ (when (oref table db-refs)
+ (princ "\nExternal Database References to this buffer:")
+ (dolist (r (oref table db-refs))
+ (princ "\n ")
+ (princ (oref r file)))
+ )
+
+ (princ (format "\nThis file contains %d tags, %d of which are includes.\n"
+ (length tags) (length inc)))
+ (let ((ok 0)
+ (unknown 0)
+ (unparsed 0)
+ (all 0))
+ (dolist (i inc)
+ (let* ((fileinner (semantic-dependency-tag-file i))
+ (tableinner (when fileinner
+ (semanticdb-file-table-object fileinner t))))
+ (cond ((not fileinner)
+ (setq unknown (1+ unknown)))
+ ((number-or-marker-p (oref tableinner pointmax))
+ (setq ok (1+ ok)))
+ (t
+ (setq unparsed (1+ unparsed))))))
+ (setq all (+ ok unknown unparsed))
+ (when (not (= 0 all))
+ (princ (format " Unknown Includes: %d\n" unknown))
+ (princ (format " Unparsed Includes: %d\n" unparsed))
+ (princ (format " Parsed Includes: %d\n" ok)))
+ )
+
+ (princ "\nInclude Path Summary:\n\n")
+ (when ede-object
+ (princ " This file's project include search is handled by the EDE object:\n")
+ (princ " Buffer Target: ")
+ (princ (object-print ede-object))
+ (princ "\n")
+ (when (not (eq ede-object ede-object-project))
+ (princ " Buffer Project: ")
+ (princ (object-print ede-object-project))
+ (princ "\n")
+ )
+ (when ede-object-project
+ (let ((loc (ede-get-locator-object ede-object-project)))
+ (princ " Backup in-project Locator: ")
+ (princ (object-print loc))
+ (princ "\n")))
+ (let ((syspath (ede-system-include-path ede-object-project)))
+ (if (not syspath)
+ (princ " EDE Project system include path: Empty\n")
+ (princ " EDE Project system include path:\n")
+ (dolist (dir syspath)
+ (princ " ")
+ (princ dir)
+ (princ "\n"))
+ )))
+
+ (princ "\n This file's system include path is:\n")
+ (dolist (dir semantic-dependency-system-include-path)
+ (princ " ")
+ (princ dir)
+ (princ "\n"))
+
+ (let ((unk semanticdb-find-lost-includes))
+ (when unk
+ (princ "\nAll unknown includes:\n")
+ (dolist (tag unk)
+ (princ " ")
+ (princ (semantic-tag-name tag))
+ (princ "\n"))
+ ))
+
+ (let* ((semanticdb-find-default-throttle
+ (if (featurep 'semanticdb-find)
+ (remq 'unloaded semanticdb-find-default-throttle)
+ nil))
+ (path (semanticdb-find-translate-path nil nil)))
+ (if (<= (length path) (length inc))
+ (princ "\nThere are currently no includes found recursively.\n")
+ ;; List the full include list.
+ (princ "\nSummary of all includes needed by ")
+ (princ (buffer-name))
+ (dolist (p path)
+ (if (slot-boundp p 'tags)
+ (princ (format "\n %s :\t%d tags, %d are includes. %s"
+ (object-name-string p)
+ (length (oref p tags))
+ (length (semantic-find-tags-by-class
+ 'include p))
+ (cond
+ ((condition-case nil
+ (oref p dirty)
+ (error nil))
+ " dirty.")
+ ((not (number-or-marker-p (oref table pointmax)))
+ " Needs to be parsed.")
+ (t ""))))
+ (princ (format "\n %s :\tUnparsed"
+ (object-name-string p))))
+ )))
+ )))
+
+\f
+;;; Unparsed Include Features
+;;
+;; This section handles changing states of unparsed include
+;; decorations base on what happens in other files.
+;;
+
+(defclass semantic-decoration-unparsed-include-cache (semanticdb-abstract-cache)
+ ()
+ "Class used to reset decorated includes.
+When an include's referring file is parsed, we need to undecorate
+any decorated referring includes.")
+
+
+(defmethod semantic-reset ((obj semantic-decoration-unparsed-include-cache))
+ "Reset OBJ back to it's empty settings."
+ (let ((table (oref obj table)))
+ ;; This is a hack. Add in something better?
+ (semanticdb-notify-references
+ table (lambda (tab me)
+ (semantic-decoration-unparsed-include-refrence-reset tab)
+ ))
+ ))
+
+(defmethod semanticdb-partial-synchronize ((cache semantic-decoration-unparsed-include-cache)
+ new-tags)
+ "Synchronize CACHE with some NEW-TAGS."
+ (if (semantic-find-tags-by-class 'include new-tags)
+ (semantic-reset cache)))
+
+(defmethod semanticdb-synchronize ((cache semantic-decoration-unparsed-include-cache)
+ new-tags)
+ "Synchronize a CACHE with some NEW-TAGS."
+ (semantic-reset cache))
+
+(defun semantic-decoration-unparsed-include-refrence-reset (table)
+ "Refresh any highlighting in buffers referred to by TABLE.
+If TABLE is not in a buffer, do nothing."
+ ;; This cache removal may seem odd in that we are "creating one", but
+ ;; since we cant get in the fcn unless one exists, this ought to be
+ ;; ok.
+ (let ((c (semanticdb-cache-get
+ table 'semantic-decoration-unparsed-include-cache)))
+ (semanticdb-cache-remove table c))
+
+ (let ((buf (semanticdb-in-buffer-p table)))
+ (when buf
+ (semantic-decorate-add-pending-decoration
+ 'semantic-decoration-unparsed-include-do-reset
+ buf)
+ )))
+
+;;;;###autoload
+(defun semantic-decoration-unparsed-include-do-reset ()
+ "Do a reset of unparsed includes in the current buffer."
+ (let* ((style (assoc "semantic-decoration-on-includes"
+ semantic-decoration-styles)))
+ (when (cdr style)
+ (let ((allinc (semantic-find-tags-included
+ (semantic-fetch-tags-fast))))
+ ;; This will do everything, but it should be speedy since it
+ ;; would have been done once already.
+ (semantic-decorate-add-decorations allinc)
+ ))))
+
+
+(provide 'semantic/decorate/include)
+
+;;; semantic/decorate/include.el ends here
--- /dev/null
+;;; semantic/decorate/mode.el --- Minor mode for decorating tags
+
+;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; A minor mode for use in decorating tags.
+;;
+;; There are two types of decorations that can be performed on a tag.
+;; You can either highlight the full tag, or you can add an
+;; independent decoration on some part of the tag body.
+;;
+;; For independent decoration in particular, managing them so that they
+;; do not get corrupted is challenging. This major mode and
+;; corresponding macros will make handling those types of decorations
+;; easier.
+;;
+
+;;; Code:
+(require 'semantic)
+(require 'semantic/decorate)
+(require 'semantic/tag-ls)
+(require 'semantic/util-modes)
+(eval-when-compile (require 'cl))
+
+;;; Styles List
+;;
+(defcustom semantic-decoration-styles nil
+ "*List of active decoration styles.
+It is an alist of \(NAME . FLAG) elements, where NAME is a style name
+and FLAG is non-nil if the style is enabled.
+See also `define-semantic-decoration-style' which will automatically
+add items to this list."
+ :group 'semantic
+ :type '(repeat (cons (string :tag "Decoration Name")
+ (boolean :tag "Enabled")))
+ )
+
+;;; Misc.
+;;
+(defsubst semantic-decorate-style-predicate (style)
+ "Return the STYLE's predicate function."
+ (intern (format "%s-p" style)))
+
+(defsubst semantic-decorate-style-highlighter (style)
+ "Return the STYLE's highlighter function."
+ (intern (format "%s-highlight" style)))
+
+;;; Base decoration API
+;;
+(defsubst semantic-decoration-p (object)
+ "Return non-nil if OBJECT is a tag decoration."
+ (and (semantic-overlay-p object)
+ (semantic-overlay-get object 'semantic-decoration)))
+
+(defsubst semantic-decoration-set-property (deco property value)
+ "Set the DECO decoration's PROPERTY to VALUE.
+Return DECO."
+ (assert (semantic-decoration-p deco))
+ (semantic-overlay-put deco property value)
+ deco)
+
+(defsubst semantic-decoration-get-property (deco property)
+ "Return the DECO decoration's PROPERTY value."
+ (assert (semantic-decoration-p deco))
+ (semantic-overlay-get deco property))
+
+(defsubst semantic-decoration-set-face (deco face)
+ "Set the face of the decoration DECO to FACE.
+Return DECO."
+ (semantic-decoration-set-property deco 'face face))
+
+(defsubst semantic-decoration-face (deco)
+ "Return the face of the decoration DECO."
+ (semantic-decoration-get-property deco 'face))
+
+(defsubst semantic-decoration-set-priority (deco priority)
+ "Set the priority of the decoration DECO to PRIORITY.
+Return DECO."
+ (assert (natnump priority))
+ (semantic-decoration-set-property deco 'priority priority))
+
+(defsubst semantic-decoration-priority (deco)
+ "Return the priority of the decoration DECO."
+ (semantic-decoration-get-property deco 'priority))
+
+(defsubst semantic-decoration-move (deco begin end)
+ "Move the decoration DECO on the region between BEGIN and END.
+Return DECO."
+ (assert (semantic-decoration-p deco))
+ (semantic-overlay-move deco begin end)
+ deco)
+\f
+;;; Tag decoration
+;;
+(defun semantic-decorate-tag (tag begin end &optional face)
+ "Add a new decoration on TAG on the region between BEGIN and END.
+If optional argument FACE is non-nil, set the decoration's face to
+FACE.
+Return the overlay that makes up the new decoration."
+ (let ((deco (semantic-tag-create-secondary-overlay tag)))
+ ;; We do not use the unlink property because we do not want to
+ ;; save the highlighting information in the DB.
+ (semantic-overlay-put deco 'semantic-decoration t)
+ (semantic-decoration-move deco begin end)
+ (semantic-decoration-set-face deco face)
+ deco))
+
+(defun semantic-decorate-clear-tag (tag &optional deco)
+ "Remove decorations from TAG.
+If optional argument DECO is non-nil, remove only that decoration."
+ (assert (or (null deco) (semantic-decoration-p deco)))
+ ;; Clear primary decorations.
+ ;; For now, just unhighlight the tag. How to deal with other
+ ;; primary decorations like invisibility, etc. ? Maybe just
+ ;; restoring default values will suffice?
+ (semantic-unhighlight-tag tag)
+ (semantic-tag-delete-secondary-overlay
+ tag (or deco 'semantic-decoration)))
+
+(defun semantic-decorate-tag-decoration (tag)
+ "Return decoration found on TAG."
+ (semantic-tag-get-secondary-overlay tag 'semantic-decoration))
+\f
+;;; Global setup of active decorations
+;;
+(defun semantic-decorate-flush-decorations (&optional buffer)
+ "Flush decorations found in BUFFER.
+BUFFER defaults to the current buffer.
+Should be used to flush decorations that might remain in BUFFER, for
+example, after tags have been refreshed."
+ (with-current-buffer (or buffer (current-buffer))
+ (dolist (o (semantic-overlays-in (point-min) (point-max)))
+ (and (semantic-decoration-p o)
+ (semantic-overlay-delete o)))))
+
+(defun semantic-decorate-clear-decorations (tag-list)
+ "Remove decorations found in tags in TAG-LIST."
+ (dolist (tag tag-list)
+ (semantic-decorate-clear-tag tag)
+ ;; recurse over children
+ (semantic-decorate-clear-decorations
+ (semantic-tag-components-with-overlays tag))))
+
+(defun semantic-decorate-add-decorations (tag-list)
+ "Add decorations to tags in TAG-LIST.
+Also make sure old decorations in the area are completely flushed."
+ (dolist (tag tag-list)
+ ;; Cleanup old decorations.
+ (when (semantic-decorate-tag-decoration tag)
+ ;; Note on below comment. This happens more as decorations are refreshed
+ ;; mid-way through their use. Remove the message.
+
+ ;; It would be nice if this never happened, but it still does
+ ;; once in a while. Print a message to help flush these
+ ;; situations
+ ;;(message "Decorations still on %s" (semantic-format-tag-name tag))
+ (semantic-decorate-clear-tag tag))
+ ;; Add new decorations.
+ (dolist (style semantic-decoration-styles)
+ (let ((pred (semantic-decorate-style-predicate (car style)))
+ (high (semantic-decorate-style-highlighter (car style))))
+ (and (cdr style)
+ (fboundp pred)
+ (funcall pred tag)
+ (fboundp high)
+ (funcall high tag))))
+ ;; Recurse on the children of all tags
+ (semantic-decorate-add-decorations
+ (semantic-tag-components-with-overlays tag))))
+\f
+;;; PENDING DECORATIONS
+;;
+;; Activities in Emacs may cause a decoration to change state. Any
+;; such identified change ought to be setup as PENDING. This means
+;; that the next idle step will do the decoration change, but at the
+;; time of the state change, minimal work would be done.
+(defvar semantic-decorate-pending-decoration-hooks nil
+ "Functions to call with pending decoration changes.")
+
+(defun semantic-decorate-add-pending-decoration (fcn &optional buffer)
+ "Add a pending decoration change represented by FCN.
+Applies only to the current BUFFER.
+The setting of FCN will be removed after it is run."
+ (save-excursion
+ (when buffer (set-buffer buffer))
+ (semantic-make-local-hook 'semantic-decorate-flush-pending-decorations)
+ (add-hook 'semantic-decorate-pending-decoration-hooks fcn nil t)))
+
+;;;;###autoload
+(defun semantic-decorate-flush-pending-decorations (&optional buffer)
+ "Flush any pending decorations for BUFFER.
+Flush functions from `semantic-decorate-pending-decoration-hooks'."
+ (save-excursion
+ (when buffer (set-buffer buffer))
+ (run-hooks 'semantic-decorate-pending-decoration-hooks)
+ ;; Always reset the hooks
+ (setq semantic-decorate-pending-decoration-hooks nil)))
+
+\f
+;;; DECORATION MODE
+;;
+;; Generic mode for handling basic highlighting and decorations.
+;;
+
+(defcustom global-semantic-decoration-mode nil
+ "*If non-nil, enable global use of command `semantic-decoration-mode'.
+When this mode is activated, decorations specified by
+`semantic-decoration-styles'."
+ :group 'semantic
+ :group 'semantic-modes
+ :type 'boolean
+ :require 'semantic/decorate/mode
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-semantic-decoration-mode (if val 1 -1))))
+
+(defun global-semantic-decoration-mode (&optional arg)
+ "Toggle global use of option `semantic-decoration-mode'.
+Decoration mode turns on all active decorations as specified
+by `semantic-decoration-styles'.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-semantic-decoration-mode
+ (semantic-toggle-minor-mode-globally
+ 'semantic-decoration-mode arg)))
+
+(defcustom semantic-decoration-mode-hook nil
+ "*Hook run at the end of function `semantic-decoration-mode'."
+ :group 'semantic
+ :type 'hook)
+
+;;;;###autoload
+(defvar semantic-decoration-mode nil
+ "Non-nil if command `semantic-decoration-mode' is enabled.
+Use the command `semantic-decoration-mode' to change this variable.")
+(make-variable-buffer-local 'semantic-decoration-mode)
+
+(defun semantic-decoration-mode-setup ()
+ "Setup the `semantic-decoration-mode' minor mode.
+The minor mode can be turned on only if the semantic feature is available
+and the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled."
+ (if semantic-decoration-mode
+ (if (not (and (featurep 'semantic) (semantic-active-p)))
+ (progn
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-decoration-mode nil)
+ (error "Buffer %s was not set up for parsing"
+ (buffer-name)))
+ ;; Add hooks
+ (semantic-make-local-hook 'semantic-after-partial-cache-change-hook)
+ (add-hook 'semantic-after-partial-cache-change-hook
+ 'semantic-decorate-tags-after-partial-reparse nil t)
+ (semantic-make-local-hook 'semantic-after-toplevel-cache-change-hook)
+ (add-hook 'semantic-after-toplevel-cache-change-hook
+ 'semantic-decorate-tags-after-full-reparse nil t)
+ ;; Add decorations to available tags. The above hooks ensure
+ ;; that new tags will be decorated when they become available.
+ (semantic-decorate-add-decorations (semantic-fetch-available-tags))
+ )
+ ;; Remove decorations from available tags.
+ (semantic-decorate-clear-decorations (semantic-fetch-available-tags))
+ ;; Cleanup any leftover crap too.
+ (semantic-decorate-flush-decorations)
+ ;; Remove hooks
+ (remove-hook 'semantic-after-partial-cache-change-hook
+ 'semantic-decorate-tags-after-partial-reparse t)
+ (remove-hook 'semantic-after-toplevel-cache-change-hook
+ 'semantic-decorate-tags-after-full-reparse t)
+ )
+ semantic-decoration-mode)
+
+;;;;###autoload
+(defun semantic-decoration-mode (&optional arg)
+ "Minor mode for decorating tags.
+Decorations are specified in `semantic-decoration-styles'.
+You can define new decoration styles with
+`define-semantic-decoration-style'.
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled."
+;;
+;;\\{semantic-decoration-map}"
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-decoration-mode 0 1))))
+ (setq semantic-decoration-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-decoration-mode)))
+ (semantic-decoration-mode-setup)
+ (run-hooks 'semantic-decoration-mode-hook)
+ (if (interactive-p)
+ (message "decoration-mode minor mode %sabled"
+ (if semantic-decoration-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-decoration-mode)
+
+(semantic-add-minor-mode 'semantic-decoration-mode
+ ""
+ nil)
+
+(defun semantic-decorate-tags-after-full-reparse (tag-list)
+ "Add decorations after a complete reparse of the current buffer.
+TAG-LIST is the list of tags recently parsed.
+Flush all existing decorations and call `semantic-decorate-add-decorations' to
+add decorations.
+Called from `semantic-after-toplevel-cache-change-hook'."
+ ;; Flush everything
+ (semantic-decorate-flush-decorations)
+ ;; Add it back on
+ (semantic-decorate-add-decorations tag-list))
+
+(defun semantic-decorate-tags-after-partial-reparse (tag-list)
+ "Add decorations when new tags are created in the current buffer.
+TAG-LIST is the list of newly created tags.
+Call `semantic-decorate-add-decorations' to add decorations.
+Called from `semantic-after-partial-cache-change-hook'."
+ (semantic-decorate-add-decorations tag-list))
+
+\f
+;;; Enable/Disable toggling
+;;
+(defun semantic-decoration-style-enabled-p (style)
+ "Return non-nil if STYLE is currently enabled.
+Return nil if the style is disabled, or does not exist."
+ (let ((pair (assoc style semantic-decoration-styles)))
+ (and pair (cdr pair))))
+
+(defun semantic-toggle-decoration-style (name &optional arg)
+ "Turn on/off the decoration style with NAME.
+Decorations are specified in `semantic-decoration-styles'.
+With prefix argument ARG, turn on if positive, otherwise off.
+Return non-nil if the decoration style is enabled."
+ (interactive
+ (list (completing-read "Decoration style: "
+ semantic-decoration-styles nil t)
+ current-prefix-arg))
+ (setq name (format "%s" name)) ;; Ensure NAME is a string.
+ (unless (equal name "")
+ (let* ((style (assoc name semantic-decoration-styles))
+ (flag (if arg
+ (> (prefix-numeric-value arg) 0)
+ (not (cdr style)))))
+ (unless (eq (cdr style) flag)
+ ;; Store the new flag.
+ (setcdr style flag)
+ ;; Refresh decorations is `semantic-decoration-mode' is on.
+ (when semantic-decoration-mode
+ (semantic-decoration-mode -1)
+ (semantic-decoration-mode 1))
+ (when (interactive-p)
+ (message "Decoration style %s turned %s" (car style)
+ (if flag "on" "off"))))
+ flag)))
+
+(defvar semantic-decoration-menu-cache nil
+ "Cache of the decoration menu.")
+
+(defun semantic-decoration-build-style-menu (style)
+ "Build a menu item for controlling a specific decoration STYLE."
+ (vector (car style)
+ `(lambda () (interactive)
+ (semantic-toggle-decoration-style
+ ,(car style)))
+ :style 'toggle
+ :selected `(semantic-decoration-style-enabled-p ,(car style))
+ ))
+
+;;;;###autoload
+(defun semantic-build-decoration-mode-menu (&rest ignore)
+ "Create a menu listing all the known decorations for toggling.
+IGNORE any input arguments."
+ (or semantic-decoration-menu-cache
+ (setq semantic-decoration-menu-cache
+ (mapcar 'semantic-decoration-build-style-menu
+ (reverse semantic-decoration-styles))
+ )))
+
+\f
+;;; Defining decoration styles
+;;
+(defmacro define-semantic-decoration-style (name doc &rest flags)
+ "Define a new decoration style with NAME.
+DOC is a documentation string describing the decoration style NAME.
+It is appended to auto-generated doc strings.
+An Optional list of FLAGS can also be specified. Flags are:
+ :enabled <value> - specify the default enabled value for NAME.
+
+
+This defines two new overload functions respectively called `NAME-p'
+and `NAME-highlight', for which you must provide a default
+implementation in respectively the functions `NAME-p-default' and
+`NAME-highlight-default'. Those functions are passed a tag. `NAME-p'
+must return non-nil to indicate that the tag should be decorated by
+`NAME-highlight'.
+
+To put primary decorations on a tag `NAME-highlight' must use
+functions like `semantic-set-tag-face', `semantic-set-tag-intangible',
+etc., found in the semantic-decorate library.
+
+To add other kind of decorations on a tag, `NAME-highlight' must use
+`semantic-decorate-tag', and other functions of the semantic
+decoration API found in this library."
+ (let ((predicate (semantic-decorate-style-predicate name))
+ (highlighter (semantic-decorate-style-highlighter name))
+ (defaultenable (if (plist-member flags :enabled)
+ (plist-get flags :enabled)
+ t))
+ )
+ `(progn
+ ;; Clear the menu cache so that new items are added when
+ ;; needed.
+ (setq semantic-decoration-menu-cache nil)
+ ;; Create an override method to specify if a given tag belongs
+ ;; to this type of decoration
+ (define-overloadable-function ,predicate (tag)
+ ,(format "Return non-nil to decorate TAG with `%s' style.\n%s"
+ name doc))
+ ;; Create an override method that will perform the highlight
+ ;; operation if the -p method returns non-nil.
+ (define-overloadable-function ,highlighter (tag)
+ ,(format "Decorate TAG with `%s' style.\n%s"
+ name doc))
+ ;; Add this to the list of primary decoration modes.
+ (add-to-list 'semantic-decoration-styles
+ (cons ',(symbol-name name)
+ ,defaultenable))
+ )))
+\f
+;;; Predefined decoration styles
+;;
+
+;;; Tag boundaries highlighting
+;;
+(define-semantic-decoration-style semantic-tag-boundary
+ "Place an overline in front of each long tag.
+Does not provide overlines for prototypes.")
+
+(defface semantic-tag-boundary-face
+ '((((class color) (background dark))
+ (:overline "cyan"))
+ (((class color) (background light))
+ (:overline "blue")))
+ "*Face used to show long tags in.
+Used by decoration style: `semantic-tag-boundary'."
+ :group 'semantic-faces)
+
+(defun semantic-tag-boundary-p-default (tag)
+ "Return non-nil if TAG is a type, or a non-prototype function."
+ (let ((c (semantic-tag-class tag)))
+ (and
+ (or
+ ;; All types get a line?
+ (eq c 'type)
+ ;; Functions which aren't prototypes get a line.
+ (and (eq c 'function)
+ (not (semantic-tag-get-attribute tag :prototype-flag)))
+ )
+ ;; Note: The below restriction confused users.
+ ;;
+ ;; Nothing smaller than a few lines
+ ;;(> (- (semantic-tag-end tag) (semantic-tag-start tag)) 150)
+ ;; Random truth
+ t)
+ ))
+
+(defun semantic-tag-boundary-highlight-default (tag)
+ "Highlight the first line of TAG as a boundary."
+ (when (bufferp (semantic-tag-buffer tag))
+ (with-current-buffer (semantic-tag-buffer tag)
+ (semantic-decorate-tag
+ tag
+ (semantic-tag-start tag)
+ (save-excursion
+ (goto-char (semantic-tag-start tag))
+ (end-of-line)
+ (forward-char 1)
+ (point))
+ 'semantic-tag-boundary-face))
+ ))
+
+;;; Private member highlighting
+;;
+(define-semantic-decoration-style semantic-decoration-on-private-members
+ "Highlight class members that are designated as PRIVATE access."
+ :enabled nil)
+
+(defface semantic-decoration-on-private-members-face
+ '((((class color) (background dark))
+ (:background "#200000"))
+ (((class color) (background light))
+ (:background "#8fffff")))
+ "*Face used to show privately scoped tags in.
+Used by the decoration style: `semantic-decoration-on-private-members'."
+ :group 'semantic-faces)
+
+(defun semantic-decoration-on-private-members-highlight-default (tag)
+ "Highlight TAG as designated to have PRIVATE access.
+Use a primary decoration."
+ (semantic-set-tag-face
+ tag 'semantic-decoration-on-private-members-face))
+
+(defun semantic-decoration-on-private-members-p-default (tag)
+ "Return non-nil if TAG has PRIVATE access."
+ (and (member (semantic-tag-class tag) '(function variable))
+ (eq (semantic-tag-protection tag) 'private)))
+
+;;; Protected member highlighting
+;;
+(defface semantic-decoration-on-protected-members-face
+ '((((class color) (background dark))
+ (:background "#000020"))
+ (((class color) (background light))
+ (:background "#fffff8")))
+ "*Face used to show protected scoped tags in.
+Used by the decoration style: `semantic-decoration-on-protected-members'."
+ :group 'semantic-faces)
+
+(define-semantic-decoration-style semantic-decoration-on-protected-members
+ "Highlight class members that are designated as PROTECTED access."
+ :enabled nil)
+
+(defun semantic-decoration-on-protected-members-p-default (tag)
+ "Return non-nil if TAG has PROTECTED access."
+ (and (member (semantic-tag-class tag) '(function variable))
+ (eq (semantic-tag-protection tag) 'protected)))
+
+(defun semantic-decoration-on-protected-members-highlight-default (tag)
+ "Highlight TAG as designated to have PROTECTED access.
+Use a primary decoration."
+ (semantic-set-tag-face
+ tag 'semantic-decoration-on-protected-members-face))
+
+(provide 'semantic/decorate/mode)
+
+;;; semantic/decorate/mode.el ends here
+
projects / emacs.git / commitdiff