;;; local-tags.el --- buffer-local tags

;; Copyright (C) 2008 Martin Rudalics

;; Time-stamp: "2008-02-18 20:41:11 martin"
;; Author: Martin Rudalics <rudalics@gmx.at>
;; Keywords: tags, imenu, etags

;; 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, 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; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

(defgroup local-tags nil
  "Buffer-local tags."
  :version "23.1"
  :group 'convenience)

(defcustom local-tags-methods '(imenu etags syntax plain)
  "List of methods for extracting tags of current buffer.
Possible members are:

 `imenu': Apply the method used by imenu for creating this buffer's
          index (`imenu--index-alist').

 `etags': Run the `etags' program on the contents of this buffer.

 `plain': Plain search (ignored when listing tags).

 `syntax': Like plain search but do not report matches within
           comments or strings (ignored when listing tags).

The methods in this list are run until one of them reports a
result.  This variable can be set in a hook, as

 (add-hook 'c-mode-hook
	   (set (make-local-variable 'local-tags-methods)
	        '(etags imenu syntax plain)))"
  :type '(repeat (choice (const :tag "imenu" imenu)
			 (const :tag "etags" etags)
			 (const :tag "syntactic search" syntax)
			 (const :tag "plain search" plain)))
  :group 'local-tags)

(defcustom local-tags-revert-buffer nil
  "Non-nil means revert buffer when visited file chenged on disk."
  :type 'boolean
  :group 'local-tags)

(defcustom local-tags-etags-program "etags"
  "Name of etags program."
  :type 'string
  :group 'local-tags)

(defcustom local-tags-etags-options '("--no-members")
  "List of options passed to etags program.
Possible options are \"--declarations\", \"-D\", \"-I\",
\"--no-globals\", and \"--no-members\".

Do not specify \"-o\", \"--output\", or \"--parse-stdin\" here,
they are passed to etags automatically."
  :type '(repeat (string :tag "Option"))
  :group 'local-tags)

(defcustom local-tags-etags-charpos nil
  "Non-nil means etags based functions report character positions.
The default has etags based functions report line numbers which
is slower when actually going to the tag but more reliable
because the etags program reports file position which might not
always translate correctly to buffer positions."
  :type 'boolean
  :group 'local-tags)

;; imenu specific part.
(defvar local-tags-imenu-tag-list nil
  "Tags created by `local-tags-imenu-list'.")
(make-variable-buffer-local 'local-tags-imenu-tag-list)

(defun local-tags-imenu-list ()
  "Retrieve tags for current buffer using imenu.
Return nil or a cons cell whose car is a list built of the symbol
`goto-char' and the `buffer-chars-modified-tick' value at the
time this list was created.  The cdr of the cons is the list of
tags created by `imenu-create-index-function' for this buffer."
  (if (and (local-variable-p 'local-tags-imenu-tag-list)
	   (= (nth 1 (car local-tags-imenu-tag-list))
	      (buffer-chars-modified-tick)))
      ;; We have a valid `local-tags-imenu-tag-list', return it.
      local-tags-imenu-tag-list
    ;; `local-tags-imenu-tag-list' either doesn't exist yet or the
    ;; buffer has been modified since it was created; (re-)build it.
    (require 'imenu)
    ;; Don't use markers for our purposes.
    (let (imenu-use-markers)
      (save-excursion
	(save-restriction
	  (widen)
	  (let ((tags (condition-case nil
			  ;; Calculate the tags.
			  (funcall imenu-create-index-function)
			(error nil))))
	    ;; Prepend `goto-char' and `buffer-chars-modified-tick' and
	    ;; save the result in `local-tags-imenu-tag-list'.
	    (setq local-tags-imenu-tag-list
		  (when tags
		    (cons (list 'goto-char (buffer-chars-modified-tick))
			  tags)))))))))

(defun local-tags-imenu-find-1 (tags tag)
  "Return list of all matches for TAG in tag-list TAGS.
TAGS is assumed to be an object created by calling
`imenu-create-index-function'."
  (let (hits)
    (dolist (item tags)
      (cond
       ((number-or-marker-p (cdr item))
	;; A useful item, return as is.
	(when (equal (car item) tag)
	  (setq hits (cons (cdr item) hits))))
       ((listp (cdr item))
	;; Recurse.
	(setq hits (nconc (local-tags-imenu-find-1 (cdr item) tag)
			  hits)))))
    hits))

(defun local-tags-imenu-find (tag)
  "Return matches for tag TAG in current buffer using imenu.
Return nil or a cons cell whose car is a list built of the symbol
`goto-char' and the `buffer-chars-modified-tick' value at the
time a list of tags was created for this buffer.  The cdr of the
cons is a list of locations matching TAG."
  (condition-case nil
      ;; Update `local-tags-imenu-tag-list' if necessary.
      (let ((tags (local-tags-imenu-list)))
	(when tags
	  (let ((hits (local-tags-imenu-find-1 (cdr tags) tag)))
	    (when hits
	      (cons (car tags)
		    ;; `local-tags-imenu-find-1' returns hits in descending
		    ;; order, reverse them.
		    (nreverse hits))))))
    (error nil)))


;; etags specific part.
(defvar local-tags-etags-buffer nil
  "Buffer used for storing etags output.")

(defvar local-tags-etags-tag-list nil
  "Tags created by `local-tags-etags-list'.")
(make-variable-buffer-local 'local-tags-etags-tag-list)

;; We use an adaption of the regexp from Roland McGrath's
;; `etags-tags-completion-table', where
;;   1 is the "guessed" tag name,
;;   2 the "explicitly specified" tag name,
;;   3 the number of the line where the tag appears, and
;;   4 (usually) the tag's line beginning position (minus 1).
(defconst local-tags-etags-regexp
  "^\\(?:\\(?:[^\177]+[^-a-zA-Z0-9_+*$:\177]+\\)?\
\\([-a-zA-Z0-9_+*$?:]+\\)[^-a-zA-Z0-9_+*$?:\177]*\\)\177\
\\(?:\\([^\n\001]+\\)\001\\)?\\([0-9]+\\)?,\\([0-9]+\\)?\n"
  "Regexp to search for tags in etags generated buffers.")

;; Note: Maybe we should consider customizing which matches may be
;; reported for etags regexp (only guessed, only explicitly specified,
;; currently it's either of them when they differ).

(defun local-tags-etags-list ()
  "Retrieve tags for current buffer using etags.
Return nil or a cons cell whose car is a list built of the
function to go to the tag, the `buffer-chars-modified-tick' value
at the time this list was created, and the values of
`local-tags-etags-options' and `local-tags-etags-charpos' used
for running etags.  The cdr of the cons is the list of tags
obtained by running `local-tags-etags-program' on this buffer."
  (if (and (local-variable-p 'local-tags-etags-tag-list)
	   (= (nth 1 (car local-tags-etags-tag-list))
	      (buffer-chars-modified-tick))
	   (equal (nth 2 (car local-tags-etags-tag-list))
		  local-tags-etags-options)
	   (equal (nth 3 (car local-tags-etags-tag-list))
		  local-tags-etags-charpos))
      ;; We have a valid `local-tags-etags-tag-list', return it.
      local-tags-etags-tag-list
    ;; `local-tags-etags-tag-list' either doesn't exist yet, or the
    ;; buffer has been modified since it was created, or some options
    ;; for running etags have changed; (re-)build it.
    (unless local-tags-etags-buffer
      ;; There's no buffer for etags output, create one.
      (setq local-tags-etags-buffer
	    ;; FIXME: Prepend space to make this buffer invisible.
	    (generate-new-buffer "*local-tags*")))
    ;; Clean the buffer for etags output.
    (with-current-buffer local-tags-etags-buffer
      (erase-buffer))
    ;; Run etags on entire buffer.
    (save-restriction
      (widen)
      (apply 'call-process-region (point-min) (point-max)
	     local-tags-etags-program nil local-tags-etags-buffer nil
	     (append
	      (list
	       "--output=-" (concat "--parse-stdin=" (buffer-name)))
	      local-tags-etags-options)))
    ;; Build the tags-list.  Make sure to apply the correct value of
    ;; `local-tags-etags-charpos' in case this has been made local in
    ;; the current buffer.
    (let ((position local-tags-etags-charpos)
	  tags ms1 ms2 location)
      (with-current-buffer local-tags-etags-buffer
	(goto-char (point-min))
	(while (re-search-forward local-tags-etags-regexp nil t)
	  ;; When we record character positions add one to the value
	  ;; returned by etags since the latter counts file positions
	  ;; from zero.
	  (setq location
		(if position
		    (1+ (string-to-number
			 (match-string-no-properties 4)))
		  (string-to-number
		   (match-string-no-properties 3))))
	  (when (setq ms1 (match-string-no-properties 1))
	    ;; We have a match for the "guessed" tag, record it.
	    (setq tags (cons (cons ms1 location) tags)))
	  (when (and (setq ms2 (match-string-no-properties 2))
		     (or (not ms1) (not (string-equal ms1 ms2))))
	    ;; We have a match for the "explicitly specified" tag and
	    ;; its name does not coincide with that of the "guessed"
	    ;; tag, record it.
	    (setq tags (cons (cons ms2 location) tags)))))
      ;; Prepend the goto function, `buffer-chars-modified-tick', and
      ;; the relevant options for running etags, and save the result in
      ;; `local-tags-etags-tag-list'.
      (setq local-tags-etags-tag-list
	    (when tags
	      (cons
	       (list
		(if local-tags-etags-charpos 'goto-char 'goto-line)
		(buffer-chars-modified-tick)
		local-tags-etags-options local-tags-etags-charpos)
	       ;; List tags in ascending buffer positions.
	       (nreverse tags)))))))

(defun local-tags-etags-find (tag)
  "Return matches for tag TAG in current buffer using etags.
Return nil or a cons cell whose car is a list built of the
function to go to tag locations, the `buffer-chars-modified-tick'
value at the time this list was created, and the values of
`local-tags-etags-options' and `local-tags-etags-charpos' used
for running etags.  The cdr of the cons is a list of locations of
tags matching TAG."
  (condition-case nil
      ;; Update `local-tags-etags-tag-list' if necessary.
      (let ((tags (local-tags-etags-list)))
	(when tags
	  (let (hits)
	    (dolist (item (cdr tags))
	      (when (string-equal (car item) tag)
		(setq hits (cons (cdr item) hits))))
	    (when hits
	      (cons (car tags) (nreverse hits))))))
    (error nil)))


;; Regexp search.
(defun local-tags-regexp-find (tag &optional syntax)
  "Return matches for tag TAG in current buffer by searching.
Return nil or a cons cell whose car is a list built of the symbol
`goto-char'.  The cdr of the cons is a list of beginning
positions for each buffer line containing a symbol matching TAG.

Optional argument SYNTAX non-nil means don't report matches
within comments or strings."
  ;; TAG must be a symbol according to the current symbol table.
  (let ((regexp (concat "\\_<" (regexp-quote tag) "\\_>"))
	hit hits end state)
    (save-excursion
      (save-restriction
	(widen)
	(goto-char (point-min))
	(while (re-search-forward regexp nil t)
	  ;; Save `match-end' since `syntax-ppss' may clobber it.
	  (setq end (match-end 0))
	  (unless (and syntax
		       (setq state (syntax-ppss end))
		       (or (nth 3 state) (nth 4 state)))
	    (setq hit (line-beginning-position))
	    (unless (and hits (= hit (car hits)))
	      ;; Don't record a hit if we have already recorded its
	      ;; `line-beginning-position'.
	      (setq hits (cons (line-beginning-position) hits))))
	  (goto-char end))))
    (when hits
      ;; Prepend `goto-char' and reverse hits.
      (cons (list 'goto-char) (nreverse hits)))))


;; List tags for current buffer.
(defun local-tags-list (&optional overriding-methods)
  "Return tags for current buffer.
The list of methods tried to find tags is specified by the
variable `local-tags-methods'.  Alternatively, optional argument
`overriding-methods' can be used to specify the list of methods.
Return nil when no tags have been found.  Otherwise, return a
cons whose caar denotes the function to call for going to a tag
and whose cdr is the list of tags returned by the respective
method.  Each entry of that list is a cons cell whose car is the
name of the tag and whose cdr is the location of the tag."
  (interactive)
  ;; Maybe revert buffer.
  (when (and local-tags-revert-buffer
	     (file-exists-p (buffer-file-name))
	     (not (verify-visited-file-modtime (current-buffer))))
    (revert-buffer)) ; Maybe we should preserve modes here?
  (let (tags)
    (catch 'tags
      ;; Run methods until one of them gets us a result.
      (dolist (method local-tags-methods)
	(if tags
	    (throw 'tags t)
	  (setq tags
		(cond
		 ((eq method 'etags)
		  (local-tags-etags-list))
		 ((eq method 'imenu)
		  (local-tags-imenu-list)))))))
    tags))

;; Find matches for a tag in current buffer.
(defun local-tags-find (tag &optional overriding-methods)
  "Return matches for tag TAG in current buffer.
The list of methods tried to find tags is specified by the
variable `local-tags-methods'.  Alternatively, optional argument
`overriding-methods' can be used to speify the list of methods.
Return nil when no matches have been found.  Otherwise, return a
cons whose caar denotes the function to call for going to a
matching location and whose cdr is the list of locations."
  (interactive)
  (let (hits)
    (catch 'hits
      ;; Run methods until one of them gets us a result.
      (dolist (method (or overriding-methods local-tags-methods))
	(if hits
	    (throw 'hits t)
	  (setq hits
		(cond
		 ((eq method 'etags)
		  (local-tags-etags-find tag))
		 ((eq method 'imenu)
		  (local-tags-imenu-find tag))
		 ((eq method 'syntax)
		  (local-tags-regexp-find tag t))
		 ((eq method 'plain)
		  (local-tags-regexp-find tag)))))))
    hits))

(provide 'local-tags)