masatake/spelunker.el, 20160525

## spelunker.el, 20160525
;;; spelunker.el --- front-end for tags file generated by universal-ctags

;; Copyright (C) 2016 Masatake YAMATO

;; This program 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.
;;
;; This program 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 this program; if not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:
(require 'assoc)

;;
;; Configuration
;;
;; Readtags and Ctags of universal-ctags are needed.
;;
(defconst spelunker-readtags-command (expand-file-name "~/var/ctags-github/readtags"))
(defconst spelunker-ctags-command    (expand-file-name "~/var/ctags-github/ctags"))

;;
;; spelunker.el requires two emacs instances: master and slave.
;; Following code passed from the master to the slave.
;;
(defconst spelunker-slave-elisp
  '(progn
     (let ((n (format "spelunker-slave:%d" (emacs-pid))))
       (hl-line-mode)
       (invert-face 'default)
       (require 'server)
       (setq server-name n)
       (setq server-use-tcp nil)
       (message "Server started at %s" n)
       (tool-bar-mode -1)
       (menu-bar-mode -1)
       (scroll-bar-mode -1)
       (global-hl-line-mode)
       (setq-default truncate-lines t)
       (server-start))
     (defun spelunker-slave-preview (file line &optional mode-line)
       (goto-line line (find-file file))
       (when mode-line
	 (setq mode-line-format mode-line))
       t)))

;; You can define spelunking sessions.
;; With M-x spelunker-switch-session, you can choose one of them as an active session.
;; To define a session use define-spelunker macro.
;;
;; e.g.
;; (define-spelunker network
;;   nil
;;   (("kernel" . "/srv/sources/sources/k/kernel/^alias-rhel7u1/pre-build/kernel-3.10.0-229.el7/linux-3.10.0-229.fc21.x86_64")
;;    ("net-tools" . "/srv/sources/sources/n/net-tools/^alias-rhel7u1/pre-build/net-tools-2.0")))
;;
;; network is the name of session. It can be passed to spelunker-switch-session.
;;
;; You can specify multiple source trees in a session. Each tree should have
;; a nich name. Here "kernel" and "net-tools" are the nick names.
;; "kernel" is for the tree, "/srv/.../linux-3.10.0-229.fc21.x86_64".
;; "net-tools" is for the tree, "/srv/.../net-tools-2.0".
;;
;; ~/.spelunker.d/${name} is used as a work space for the session.
;;
(defvar spelunker-session nil)
(defun spelunker-make (name workspace source)
  (let* ((workspace (or workspace
			(concat (file-name-as-directory (expand-file-name "~/.spelunker.d"))  (symbol-name name))))
	 (build-filename (lambda (b)
			   (expand-file-name (concat (file-name-as-directory workspace) (symbol-name name) b))))
	 (ses `((name . ,name)
		(root . ,source)
		(tags-file . ,(funcall build-filename ".tags"))
		(scratch-file . ,(funcall build-filename ".scratch"))
		(optlib-file . ,(funcall build-filename  ".ctags")))))
    (make-directory workspace t)
    ses))

(defvar spelunker-sessions ())
(defmacro define-spelunker (name workspace source)
  `(let ((tmp spelunker-sessions))
     (setq spelunker-sessions (cons (cons ',name (spelunker-make ',name ,workspace ',source ))
				    (adelete 'spelunker-sessions ',name)))
     (unless tmp
       (setq spelunker-session (car spelunker-sessions)))
     (easy-menu-define spelunker-session-menu global-map
       "Menu for choosing spelunker sessions."
       `("Sessions"
	 ,@(mapcar (lambda (ses)
		     `[,(symbol-name (car ses)) (spelunker-switch-session ',(car ses))])
		   spelunker-sessions)))))

(defun spelunker-stitching-keyword ()
  (format "spelunker-%s" (symbol-name (aget spelunker-session 'name))))
(defun spelunker-switch-session (session)
  (interactive (list (completing-read (format "Name (default: %s): " (aget (car spelunker-sessions) 'name))
				      spelunker-sessions)))
  (let ((session (if (stringp session) (intern session) session)))
    (setq spelunker-session (aget spelunker-sessions session))
    (when (boundp 'stitch-read-keywords-history)
      (let ((keyword (spelunker-stitching-keyword)))
	(unless (equal (car stitch-read-keywords-history)
		       keyword)
	  (setq stitch-read-keywords-history
		(cons keyword stitch-read-keywords-history)))))))

(defvar spelunker-use-extra-emacs t)

;;
;; Global binding
;;
(define-key global-map [kp-0]         'spelunker-tags-toggle)
(define-key global-map [kp-6]         'spelunker-list-tags-with-prefix)
(define-key global-map [kp-4]         'spelunker-list-tags-with-suffix)
(define-key global-map [kp-2]         'spelunker-list-tags-of-subclasses)
;(define-key global-map [kp-8]         'spelunker-list-tags-of-superclasses)
(define-key global-map [S-kp-subtract] 'spelunker-list-stitching)

(define-key global-map [kp-divide]    'spelunker-dired)
(define-key global-map [kp-multiply]  'spelunker-find-grep)
(define-key global-map [kp-decimal]   'spelunker-tags-show-candidates)
(define-key global-map "\M-."   'spelunker-tags-show-candidates)

(define-key global-map [kp-subtract]  'spelunker-make-scratch-here)
(define-key global-map [kp-add]       'pop-tag-mark)

(defun spelunker-make-scratch-here ()
  (interactive)
  (spelunker-history-record 'scratch
   (find-file (aget spelunker-session 'scratch-file))))


(defun spelunker-list-stitching ()
  (interactive)
  (when (featurep 'stitch)
    (stitch-list-annotation (list (intern  (spelunker-stitching-keyword))))))

(defmacro spelunker-history-record (class &rest body)
  `(progn
     (ring-insert find-tag-marker-ring (point-marker))
     (prog1 (progn ,@body)
       ;; (ring-insert find-tag-marker-ring (point-marker))
       ;; (ring-insert find-tag-marker-ring (point-marker))
       )))

;;
;;
;;
(require 'etags)

(defun spelunker-root-nickname (rd)
  (let ((roots (aget spelunker-session 'root)))
    (cond
     ((stringp roots)
      t)
     ((and (listp roots) (stringp (car roots)))
      (if (member rd roots)
	  t
	nil))
     ((and (listp roots) (listp (car roots)))
      (car (rassoc
	    (directory-file-name rd)
	    roots)))
     (t
      nil))))

(defun spelunker-roots ()
  (let ((roots (aget spelunker-session 'root)))
    (cond
     ((stringp roots)
      (list roots))
     ((and (listp roots) (stringp (car roots)))
      roots)
     ((and (listp roots) (listp (car roots)))
      (mapcar (lambda (elt)
		(cdr elt)) roots)))))

(defun spelunker-tags-file ()
  (let ((f (aget spelunker-session 'tags-file))
	(optlib (aget spelunker-session 'optlib-file)))
    (if (file-exists-p f)
	f
      (let ((roots (spelunker-roots))
	    (opts `(
		   "-o"
		   ,f
		   "--fields=*"
		   "--extra=*"
		   "--kinds-*=*"
		   "--kinds-C=-lzp"
		   "--kinds-C++=-lzp"
		   "--kinds-Java=-l"
		   "--excmd=mixed"
		   ,@(when optlib (list (format "--options=%s" optlib)))
		   "-R"
		   )))
	(message "Making tags with %s" opts)
	(if (eq (apply 'call-process spelunker-ctags-command
		       nil
		       nil
		       nil
		       (append opts roots)
		       ) 0)
	    (spelunker-tags-file)
	  (error "failed to run ctags: %s" (append opts roots)))))))

(defun spelunker-tags-toggle (&optional show)
  (interactive)
  (if (and (not show)
	   (buffer-file-name)
	   (or (equal (file-name-base (buffer-file-name)) "tags")
	       (equal (file-name-extension (buffer-file-name)) "tags")))
      (kill-buffer-and-window)
    (let ((large-file-warning-threshold nil))
      (find-file-read-only-other-window (spelunker-tags-file)))))

(defun spelunker-get-root ()
  (let ((roots (aget spelunker-session 'root))
	(default-root (when spelunker-associated-root
			(spelunker-root-nickname
			 spelunker-associated-root)
			  )))
    (cond
     ((stringp roots)
      (aget spelunker-session roots))
     ((listp roots)
      (let ((root (completing-read (if default-root
				       (format "Root [%s]: " default-root)
				       "Root: ")
				   (if (listp (car roots))
				       (mapcar #'car roots)
				     roots)
				   nil
				   nil
				   nil
				   nil
				   default-root
				   )))
	(let ((root (if (equal "" root)
			(car (if (listp (car roots))
				 (mapcar #'car roots)
			       roots))
		      root)))
	  (if (listp (car roots))
	      (aget roots root)
	    root)))))))

(defvar-local spelunker-associated-root nil)
(defun spelunker-set-associated-root (d)
  (setq-local spelunker-associated-root d))
(defun spelunker-dired ()
  (interactive)
  (let ((d (spelunker-get-root)))
    (with-current-buffer (dired d)
      (spelunker-set-associated-root d))
    ))

(defun spelunker-find-grep ()
  (interactive)
  (let ((gb (get-buffer "*grep*")))
    (if (or (not gb) (eq gb (current-buffer)))
	(let ((d (spelunker-get-root)))
	  (dired d)
	  (spelunker-set-associated-root d)
	  (call-interactively 'find-grep)
	  (with-current-buffer (get-buffer "*grep*")
	    (spelunker-set-associated-root d)))
      (pop-to-buffer gb))))

;; (eq? $name $str)
(defun spelunker-search-forward (str qualified)
  (interactive "sName: \nP")
  (let ((p (point)))
    (if qualified
	(end-of-line)
      (goto-char (point-min)))
    (if (re-search-forward (concat (if qualified
				       "^[^\t]+[.]"
				     "^")
				   (regexp-quote str) "\t")
			   nil t)
	(progn (beginning-of-line) t)
      (goto-char p)
      nil)))

(defun spelunker-tags-show-candidates (n)
  (interactive (list (read-from-minibuffer (format "Name (default: %s): " (symbol-at-point))
					   nil nil t
					   nil
					   (thing-at-point 'symbol))))
  (ring-insert find-tag-marker-ring (point-marker))
  (spelunker-tags-toggle t)
  (spelunker-search-forward (symbol-name n) nil)
  (sit-for 0)
  (eldoc-message (funcall eldoc-documentation-function))
  )

;;
;; Spelunker mode
;;
(define-minor-mode spelunker-multiline-display-mode "" nil
  " \\n"
  nil
  (font-lock-mode)
  (font-lock-mode))
(defun spelunker-extra-separator ()
  (if spelunker-multiline-display-mode "\n" ""))

(defun spelunker-font-lock-keywords (root)
  "Default font-lock-keywords for `spelunker-mode'."
  `(
    ("^!_.*" 0 'mode-line-inactive)
    ("^\\([^\t]+\\)[\t]" 1 font-lock-function-name-face)
    ,@(mapcar
       (lambda (r)
	 (let ((prefix (if (stringp r) r (cdr r)))
	       (replacement (if (stringp r)
				""
			      (format "%s:" (car r)))))
	   `(,prefix 0 (let ((b (match-beginning 0))
			     (e (match-end 0))
			     (p (list 'display
				      (concat
				       (spelunker-extra-separator)
				       (if spelunker-multiline-display-mode
					   "	"
					 "")
				       ,replacement))))
			 (add-text-properties
			  b e `(display ,p))
			 'file-name-shadow))))
       (if (stringp root)
	   (list root)
	 root))
    ("	\\(/\\^.*\\)\\/;\"" 1 (let ((str (concat (spelunker-extra-separator)
						 (match-string 0)
						 (spelunker-extra-separator)))
				    (b (match-beginning 0))
				    (e (match-end 0)))
				(add-text-properties
				 b e (if spelunker-multiline-display-mode
					 `(display ,str)
				       '(invisible t)
				 ))
				'bold))
    ("\tkind:\\([^\t]+\\)"  1 font-lock-warning-face)
    ("\trole:\\([^\t]+\\)"  1 font-lock-warning-face)
    ("\tlanguage:\\([^\t]+\\)"  1 font-lock-type-face)
    ("\t\\(scope\\):" 1 font-lock-keyword-face)
    ("\t\\([a-zA-Z0-9]+\\):" 1 font-lock-constant-face)
    )
  )

(defun spelunker-list-tags-with-prefix (prefix)
  (interactive (list (read-from-minibuffer (format "Prefix (default: %s): "
						   (symbol-at-point))
					   nil nil t
					   nil
					   (thing-at-point 'symbol))))
  (spelunker-query-tags `(prefix? $name ,(substring-no-properties
					  (symbol-name prefix)
					  0 nil))))

(defun spelunker-list-tags-with-suffix (suffix)
  (interactive (list (read-from-minibuffer (format "Suffix (default: %s): "
						   (symbol-at-point))
					   nil nil t
					   nil
					   (thing-at-point 'symbol))))
  (spelunker-query-tags `(suffix? $name ,(substring-no-properties
					  (symbol-name suffix)
					  0 nil))))

(defun spelunker-list-tags-of-subclasses (parent)
  (interactive (list (read-from-minibuffer (format "Parent (default: %s): "
						   (symbol-at-point))
					   nil nil t
					   nil
					   (thing-at-point 'symbol))))
  (spelunker-query-tags `(member ,(substring-no-properties
				   (symbol-name parent)
				   0 nil)  $inherits)))

(defun spelunker-query-tags (sexp)
  (interactive "xExpression: ")
  (ring-insert find-tag-marker-ring (point-marker))
  (let* ((n (format "%s/%S"
		    (file-name-nondirectory (aget spelunker-session 'tags-file))
		    sexp))
	 (b (get-buffer n)))
    (if b
	(pop-to-buffer b)
      (let* ((b (get-buffer-create n))
	     (r (call-process spelunker-readtags-command
			      nil
			      b
			      t
			      "-t"
			      (spelunker-tags-file)
			      "-e"
			      "-n"
			      "-Q" (format "%S" sexp)
			      "-l")))
	(pop-to-buffer b)
	(spelunker-mode)
	(goto-char (point-min))
	r))))

(defun spelunker-jump-pos ()
  (save-excursion (beginning-of-line)
		  (if (re-search-forward "^\\([^\t]+\\)\t\\([^\t]+\\).*\tline:\\([0-9]+\\).*" (line-end-position))
		      (cons (match-string-no-properties 2)
			    (string-to-number (match-string-no-properties 3)))
		    nil)))

(defun spelunker-jump ()
  (interactive)
  (let ((pos (spelunker-jump-pos)))
    (if pos
	(spelunker-history-record 'tag
	  (ring-insert find-tag-marker-ring (point-marker))
	  (find-file (car pos))
	  (goto-line (cdr pos)))
      (error "failed to get position info"))))

(defun spelunker-forward-field (&optional arg)
  (interactive "^p")
  (if (> arg 0)
      (re-search-forward "\t\\|\\'" (line-end-position) nil arg)
    (re-search-backward "^\\|\\(.+\t\\)" (line-beginning-position) nil (abs arg))))

(defun spelunker-get-entry (entry)
  (case entry
    ('name
     (save-excursion (beginning-of-line)
		     (when (re-search-forward "^\\([^\t]+\\)\t" (line-end-position) t)
		       (match-string-no-properties 1))))
    ('file
     (save-excursion (beginning-of-line)
		     (when (re-search-forward "^\\([^\t]+\\)\t\\([^\t]+\\)\t" (line-end-position) t)
		       (match-string-no-properties 2))))
    ('pattern
     (save-excursion (beginning-of-line)
		     (when (re-search-forward "^\\([^\t]+\\)\t\\([^\t]+\\)\t\\([^\t]+\\);\"\t" (line-end-position) t)
		       (match-string-no-properties 3))))
    (t
     (save-excursion (beginning-of-line)
		     (when (and (re-search-forward "^\\([^\t]+\\)\t\\([^\t]+\\)\t\\([^\t]+\\);\"\t" (line-end-position) t)
				(progn (goto-char (match-end 0)) t)
				(re-search-forward (concat (regexp-quote
							    (if (stringp entry)
								entry
							      (symbol-name entry)))
								":\\([^\t]+\\)")
						   (line-end-position) t))
		       (match-string-no-properties 1))))))

(defun spelunker-horizontal-reposition ()
  (interactive)
  (set-window-hscroll
   (get-buffer-window (current-buffer))
   (- (current-column) 6)))

(defun spelunker-goto-parent-class ()
  (interactive)
  (let ((p (spelunker-get-entry 'inherits)))
    (when p
      (spelunker-search-forward p nil))))

(defun spelunker-make-preview-txt (file line range)
  (let* ((base line)
	 (b (if (< base 2) base (- base 2)))
	 (e (+ base range)))
    (process-lines "sed" "-n" "-e" (format "%s,%sp" b e) file)))

(defvar spelunker-slave-process nil)
(defun spelunker-eldoc-document ()
  (let* ((pos (spelunker-jump-pos))
	 (file (car pos))
	 (line (cdr pos)))
    (if spelunker-use-extra-emacs
	(let ((server-use-tcp nil))
	  (when (not (and spelunker-slave-process
			  (process-live-p spelunker-slave-process)))
	    (setq spelunker-slave-process (start-process "spelunker-slave"
							 nil
							 "emacs" "-Q" "--eval" (format "%S" spelunker-slave-elisp)
							 )))
	  (server-eval-at (format "spelunker-slave:%d" (process-id spelunker-slave-process))
			  `(spelunker-slave-preview ,file ,line
						    ,(mapconcat 'identity
								(nreverse (split-string file "/"))
								" > ")
						    ))

	  "")
      (let ((preview-txt (spelunker-make-preview-txt file
						     line
						     3)))
	(save-excursion (beginning-of-line)
			(when (re-search-forward ".*;\"\t\\(.*\\)$"
						 (line-end-position) t)
			  (let ((inline (match-string 1)))
			    (concat
			     (if spelunker-multiline-display-mode "" inline)
			     (if spelunker-multiline-display-mode "" "\n")
			     (if spelunker-multiline-display-mode "" (propertize file 'face 'mode-line))
			     (if spelunker-multiline-display-mode "" "\n")
			     (mapconcat 'identity preview-txt "\n")
			     ))))))))

(define-derived-mode spelunker-mode prog-mode "Spelunker"
   "A major mode to browsing tags file generated by ctags"
   (setq-local font-lock-defaults
	       `(,(spelunker-font-lock-keywords (aget spelunker-session 'root)) t))
   (define-key spelunker-mode-map "|" 'spelunker-query-tags)
   (define-key spelunker-mode-map "\C-\\" 'spelunker-multiline-display-mode)
   (define-key spelunker-mode-map "q" 'spelunker-tags-toggle)
   (define-key spelunker-mode-map "^" 'spelunker-goto-parent-class)
   (define-key spelunker-mode-map [return] 'spelunker-jump)
   (define-key spelunker-mode-map [kp-enter] 'spelunker-jump)
   (setq-local forward-sexp-function 'spelunker-forward-field)
   (define-key spelunker-mode-map "\C-c\C-l" 'spelunker-horizontal-reposition)
   (setq-local eldoc-documentation-function 'spelunker-eldoc-document)
   (setq-local case-fold-search nil)
   (setq-local tab-width 3)
   (turn-on-eldoc-mode)
   (hl-line-mode t)
   (setq-local truncate-lines t)
   (setq-local buffer-read-only t))
(setq auto-mode-alist (append '(("\\.tags$" . spelunker-mode)
				("\\<tags$" . spelunker-mode))
			    auto-mode-alist))
(add-to-list 'font-lock-extra-managed-props 'invisible)
(add-to-list 'font-lock-extra-managed-props 'display)


(require 'compile)
(defun compile-goto-error (&optional event)
  "Visit the source for the error message at point.
Use this command in a compilation log buffer."
  (interactive (list last-input-event))
  (if event (posn-set-point (event-end event)))
  (or (compilation-buffer-p (current-buffer))
      (error "Not in a compilation buffer"))
  (compilation--ensure-parse (point))
  (ring-insert find-tag-marker-ring (point-marker))
  (if (get-text-property (point) 'compilation-directory)
      (dired-other-window
       (car (get-text-property (point) 'compilation-directory)))
    (setq compilation-current-error (point))
    (next-error-internal)))

(provide 'spelunker)
	;;; spelunker.el --- front-end for tags file generated by universal-ctags

	;; Copyright (C) 2016 Masatake YAMATO

	;; This program 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.
	;;
	;; This program 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 this program; if not, see <http://www.gnu.org/licenses/>.

	;;; Commentary:

	;;; Code:
	(require 'assoc)

	;;
	;; Configuration
	;;
	;; Readtags and Ctags of universal-ctags are needed.
	;;
	(defconst spelunker-readtags-command (expand-file-name "~/var/ctags-github/readtags"))
	(defconst spelunker-ctags-command (expand-file-name "~/var/ctags-github/ctags"))

	;;
	;; spelunker.el requires two emacs instances: master and slave.
	;; Following code passed from the master to the slave.
	;;
	(defconst spelunker-slave-elisp
	'(progn
	(let ((n (format "spelunker-slave:%d" (emacs-pid))))
	(hl-line-mode)
	(invert-face 'default)
	(require 'server)
	(setq server-name n)
	(setq server-use-tcp nil)
	(message "Server started at %s" n)
	(tool-bar-mode -1)
	(menu-bar-mode -1)
	(scroll-bar-mode -1)
	(global-hl-line-mode)
	(setq-default truncate-lines t)
	(server-start))
	(defun spelunker-slave-preview (file line &optional mode-line)
	(goto-line line (find-file file))
	(when mode-line
	(setq mode-line-format mode-line))
	t)))

	;; You can define spelunking sessions.
	;; With M-x spelunker-switch-session, you can choose one of them as an active session.
	;; To define a session use define-spelunker macro.
	;;
	;; e.g.
	;; (define-spelunker network
	;; nil
	;; (("kernel" . "/srv/sources/sources/k/kernel/^alias-rhel7u1/pre-build/kernel-3.10.0-229.el7/linux-3.10.0-229.fc21.x86_64")
	;; ("net-tools" . "/srv/sources/sources/n/net-tools/^alias-rhel7u1/pre-build/net-tools-2.0")))
	;;
	;; network is the name of session. It can be passed to spelunker-switch-session.
	;;
	;; You can specify multiple source trees in a session. Each tree should have
	;; a nich name. Here "kernel" and "net-tools" are the nick names.
	;; "kernel" is for the tree, "/srv/.../linux-3.10.0-229.fc21.x86_64".
	;; "net-tools" is for the tree, "/srv/.../net-tools-2.0".
	;;
	;; ~/.spelunker.d/${name} is used as a work space for the session.
	;;
	(defvar spelunker-session nil)
	(defun spelunker-make (name workspace source)
	(let* ((workspace (or workspace
	(concat (file-name-as-directory (expand-file-name "~/.spelunker.d")) (symbol-name name))))
	(build-filename (lambda (b)
	(expand-file-name (concat (file-name-as-directory workspace) (symbol-name name) b))))
	(ses `((name . ,name)
	(root . ,source)
	(tags-file . ,(funcall build-filename ".tags"))
	(scratch-file . ,(funcall build-filename ".scratch"))
	(optlib-file . ,(funcall build-filename ".ctags")))))
	(make-directory workspace t)
	ses))

	(defvar spelunker-sessions ())
	(defmacro define-spelunker (name workspace source)
	`(let ((tmp spelunker-sessions))
	(setq spelunker-sessions (cons (cons ',name (spelunker-make ',name ,workspace ',source ))
	(adelete 'spelunker-sessions ',name)))
	(unless tmp
	(setq spelunker-session (car spelunker-sessions)))
	(easy-menu-define spelunker-session-menu global-map
	"Menu for choosing spelunker sessions."
	`("Sessions"
	,@(mapcar (lambda (ses)
	`[,(symbol-name (car ses)) (spelunker-switch-session ',(car ses))])
	spelunker-sessions)))))

	(defun spelunker-stitching-keyword ()
	(format "spelunker-%s" (symbol-name (aget spelunker-session 'name))))
	(defun spelunker-switch-session (session)
	(interactive (list (completing-read (format "Name (default: %s): " (aget (car spelunker-sessions) 'name))
	spelunker-sessions)))
	(let ((session (if (stringp session) (intern session) session)))
	(setq spelunker-session (aget spelunker-sessions session))
	(when (boundp 'stitch-read-keywords-history)
	(let ((keyword (spelunker-stitching-keyword)))
	(unless (equal (car stitch-read-keywords-history)
	keyword)
	(setq stitch-read-keywords-history
	(cons keyword stitch-read-keywords-history)))))))

	(defvar spelunker-use-extra-emacs t)

	;;
	;; Global binding
	;;
	(define-key global-map [kp-0] 'spelunker-tags-toggle)
	(define-key global-map [kp-6] 'spelunker-list-tags-with-prefix)
	(define-key global-map [kp-4] 'spelunker-list-tags-with-suffix)
	(define-key global-map [kp-2] 'spelunker-list-tags-of-subclasses)
	;(define-key global-map [kp-8] 'spelunker-list-tags-of-superclasses)
	(define-key global-map [S-kp-subtract] 'spelunker-list-stitching)

	(define-key global-map [kp-divide] 'spelunker-dired)
	(define-key global-map [kp-multiply] 'spelunker-find-grep)
	(define-key global-map [kp-decimal] 'spelunker-tags-show-candidates)
	(define-key global-map "\M-." 'spelunker-tags-show-candidates)

	(define-key global-map [kp-subtract] 'spelunker-make-scratch-here)
	(define-key global-map [kp-add] 'pop-tag-mark)

	(defun spelunker-make-scratch-here ()
	(interactive)
	(spelunker-history-record 'scratch
	(find-file (aget spelunker-session 'scratch-file))))


	(defun spelunker-list-stitching ()
	(interactive)
	(when (featurep 'stitch)
	(stitch-list-annotation (list (intern (spelunker-stitching-keyword))))))

	(defmacro spelunker-history-record (class &rest body)
	`(progn
	(ring-insert find-tag-marker-ring (point-marker))
	(prog1 (progn ,@body)
	;; (ring-insert find-tag-marker-ring (point-marker))
	;; (ring-insert find-tag-marker-ring (point-marker))
	)))

	;;
	;;
	;;
	(require 'etags)

	(defun spelunker-root-nickname (rd)
	(let ((roots (aget spelunker-session 'root)))
	(cond
	((stringp roots)
	t)
	((and (listp roots) (stringp (car roots)))
	(if (member rd roots)
	t
	nil))
	((and (listp roots) (listp (car roots)))
	(car (rassoc
	(directory-file-name rd)
	roots)))
	(t
	nil))))

	(defun spelunker-roots ()
	(let ((roots (aget spelunker-session 'root)))
	(cond
	((stringp roots)
	(list roots))
	((and (listp roots) (stringp (car roots)))
	roots)
	((and (listp roots) (listp (car roots)))
	(mapcar (lambda (elt)
	(cdr elt)) roots)))))

	(defun spelunker-tags-file ()
	(let ((f (aget spelunker-session 'tags-file))
	(optlib (aget spelunker-session 'optlib-file)))
	(if (file-exists-p f)
	f
	(let ((roots (spelunker-roots))
	(opts `(
	"-o"
	,f
	"--fields=*"
	"--extra=*"
	"--kinds-="
	"--kinds-C=-lzp"
	"--kinds-C++=-lzp"
	"--kinds-Java=-l"
	"--excmd=mixed"
	,@(when optlib (list (format "--options=%s" optlib)))
	"-R"
	)))
	(message "Making tags with %s" opts)
	(if (eq (apply 'call-process spelunker-ctags-command
	nil
	nil
	nil
	(append opts roots)
	) 0)
	(spelunker-tags-file)
	(error "failed to run ctags: %s" (append opts roots)))))))

	(defun spelunker-tags-toggle (&optional show)
	(interactive)
	(if (and (not show)
	(buffer-file-name)
	(or (equal (file-name-base (buffer-file-name)) "tags")
	(equal (file-name-extension (buffer-file-name)) "tags")))
	(kill-buffer-and-window)
	(let ((large-file-warning-threshold nil))
	(find-file-read-only-other-window (spelunker-tags-file)))))

	(defun spelunker-get-root ()
	(let ((roots (aget spelunker-session 'root))
	(default-root (when spelunker-associated-root
	(spelunker-root-nickname
	spelunker-associated-root)
	)))
	(cond
	((stringp roots)
	(aget spelunker-session roots))
	((listp roots)
	(let ((root (completing-read (if default-root
	(format "Root [%s]: " default-root)
	"Root: ")
	(if (listp (car roots))
	(mapcar #'car roots)
	roots)
	nil
	nil
	nil
	nil
	default-root
	)))
	(let ((root (if (equal "" root)
	(car (if (listp (car roots))
	(mapcar #'car roots)
	roots))
	root)))
	(if (listp (car roots))
	(aget roots root)
	root)))))))

	(defvar-local spelunker-associated-root nil)
	(defun spelunker-set-associated-root (d)
	(setq-local spelunker-associated-root d))
	(defun spelunker-dired ()
	(interactive)
	(let ((d (spelunker-get-root)))
	(with-current-buffer (dired d)
	(spelunker-set-associated-root d))
	))

	(defun spelunker-find-grep ()
	(interactive)
	(let ((gb (get-buffer "grep")))
	(if (or (not gb) (eq gb (current-buffer)))
	(let ((d (spelunker-get-root)))
	(dired d)
	(spelunker-set-associated-root d)
	(call-interactively 'find-grep)
	(with-current-buffer (get-buffer "grep")
	(spelunker-set-associated-root d)))
	(pop-to-buffer gb))))

	;; (eq? $name $str)
	(defun spelunker-search-forward (str qualified)
	(interactive "sName: \nP")
	(let ((p (point)))
	(if qualified
	(end-of-line)
	(goto-char (point-min)))
	(if (re-search-forward (concat (if qualified
	"^[^\t]+[.]"
	"^")
	(regexp-quote str) "\t")
	nil t)
	(progn (beginning-of-line) t)
	(goto-char p)
	nil)))

	(defun spelunker-tags-show-candidates (n)
	(interactive (list (read-from-minibuffer (format "Name (default: %s): " (symbol-at-point))
	nil nil t
	nil
	(thing-at-point 'symbol))))
	(ring-insert find-tag-marker-ring (point-marker))
	(spelunker-tags-toggle t)
	(spelunker-search-forward (symbol-name n) nil)
	(sit-for 0)
	(eldoc-message (funcall eldoc-documentation-function))
	)

	;;
	;; Spelunker mode
	;;
	(define-minor-mode spelunker-multiline-display-mode "" nil
	" \\n"
	nil
	(font-lock-mode)
	(font-lock-mode))
	(defun spelunker-extra-separator ()
	(if spelunker-multiline-display-mode "\n" ""))

	(defun spelunker-font-lock-keywords (root)
	"Default font-lock-keywords for `spelunker-mode'."
	`(
	("^!_.*" 0 'mode-line-inactive)
	("^\\([^\t]+\\)[\t]" 1 font-lock-function-name-face)
	,@(mapcar
	(lambda (r)
	(let ((prefix (if (stringp r) r (cdr r)))
	(replacement (if (stringp r)
	""
	(format "%s:" (car r)))))
	`(,prefix 0 (let ((b (match-beginning 0))
	(e (match-end 0))
	(p (list 'display
	(concat
	(spelunker-extra-separator)
	(if spelunker-multiline-display-mode
	" "
	"")
	,replacement))))
	(add-text-properties
	b e `(display ,p))
	'file-name-shadow))))
	(if (stringp root)
	(list root)
	root))
	(" \\(/\\^.*\\)\\/;\"" 1 (let ((str (concat (spelunker-extra-separator)
	(match-string 0)
	(spelunker-extra-separator)))
	(b (match-beginning 0))
	(e (match-end 0)))
	(add-text-properties
	b e (if spelunker-multiline-display-mode
	`(display ,str)
	'(invisible t)
	))
	'bold))
	("\tkind:\\([^\t]+\\)" 1 font-lock-warning-face)
	("\trole:\\([^\t]+\\)" 1 font-lock-warning-face)
	("\tlanguage:\\([^\t]+\\)" 1 font-lock-type-face)
	("\t\\(scope\\):" 1 font-lock-keyword-face)
	("\t\\([a-zA-Z0-9]+\\):" 1 font-lock-constant-face)
	)
	)

	(defun spelunker-list-tags-with-prefix (prefix)
	(interactive (list (read-from-minibuffer (format "Prefix (default: %s): "
	(symbol-at-point))
	nil nil t
	nil
	(thing-at-point 'symbol))))
	(spelunker-query-tags `(prefix? $name ,(substring-no-properties
	(symbol-name prefix)
	0 nil))))

	(defun spelunker-list-tags-with-suffix (suffix)
	(interactive (list (read-from-minibuffer (format "Suffix (default: %s): "
	(symbol-at-point))
	nil nil t
	nil
	(thing-at-point 'symbol))))
	(spelunker-query-tags `(suffix? $name ,(substring-no-properties
	(symbol-name suffix)
	0 nil))))

	(defun spelunker-list-tags-of-subclasses (parent)
	(interactive (list (read-from-minibuffer (format "Parent (default: %s): "
	(symbol-at-point))
	nil nil t
	nil
	(thing-at-point 'symbol))))
	(spelunker-query-tags `(member ,(substring-no-properties
	(symbol-name parent)
	0 nil) $inherits)))

	(defun spelunker-query-tags (sexp)
	(interactive "xExpression: ")
	(ring-insert find-tag-marker-ring (point-marker))
	(let* ((n (format "%s/%S"
	(file-name-nondirectory (aget spelunker-session 'tags-file))
	sexp))
	(b (get-buffer n)))
	(if b
	(pop-to-buffer b)
	(let* ((b (get-buffer-create n))
	(r (call-process spelunker-readtags-command
	nil
	b
	t
	"-t"
	(spelunker-tags-file)
	"-e"
	"-n"
	"-Q" (format "%S" sexp)
	"-l")))
	(pop-to-buffer b)
	(spelunker-mode)
	(goto-char (point-min))
	r))))

	(defun spelunker-jump-pos ()
	(save-excursion (beginning-of-line)
	(if (re-search-forward "^\\([^\t]+\\)\t\\([^\t]+\\).\tline:\\([0-9]+\\)." (line-end-position))
	(cons (match-string-no-properties 2)
	(string-to-number (match-string-no-properties 3)))
	nil)))

	(defun spelunker-jump ()
	(interactive)
	(let ((pos (spelunker-jump-pos)))
	(if pos
	(spelunker-history-record 'tag
	(ring-insert find-tag-marker-ring (point-marker))
	(find-file (car pos))
	(goto-line (cdr pos)))
	(error "failed to get position info"))))

	(defun spelunker-forward-field (&optional arg)
	(interactive "^p")
	(if (> arg 0)
	(re-search-forward "\t\\\|\\'" (line-end-position) nil arg)
	(re-search-backward "^\\\|\\(.+\t\\)" (line-beginning-position) nil (abs arg))))

	(defun spelunker-get-entry (entry)
	(case entry
	('name
	(save-excursion (beginning-of-line)
	(when (re-search-forward "^\\([^\t]+\\)\t" (line-end-position) t)
	(match-string-no-properties 1))))
	('file
	(save-excursion (beginning-of-line)
	(when (re-search-forward "^\\([^\t]+\\)\t\\([^\t]+\\)\t" (line-end-position) t)
	(match-string-no-properties 2))))
	('pattern
	(save-excursion (beginning-of-line)
	(when (re-search-forward "^\\([^\t]+\\)\t\\([^\t]+\\)\t\\([^\t]+\\);\"\t" (line-end-position) t)
	(match-string-no-properties 3))))
	(t
	(save-excursion (beginning-of-line)
	(when (and (re-search-forward "^\\([^\t]+\\)\t\\([^\t]+\\)\t\\([^\t]+\\);\"\t" (line-end-position) t)
	(progn (goto-char (match-end 0)) t)
	(re-search-forward (concat (regexp-quote
	(if (stringp entry)
	entry
	(symbol-name entry)))
	":\\([^\t]+\\)")
	(line-end-position) t))
	(match-string-no-properties 1))))))

	(defun spelunker-horizontal-reposition ()
	(interactive)
	(set-window-hscroll
	(get-buffer-window (current-buffer))
	(- (current-column) 6)))

	(defun spelunker-goto-parent-class ()
	(interactive)
	(let ((p (spelunker-get-entry 'inherits)))
	(when p
	(spelunker-search-forward p nil))))

	(defun spelunker-make-preview-txt (file line range)
	(let* ((base line)
	(b (if (< base 2) base (- base 2)))
	(e (+ base range)))
	(process-lines "sed" "-n" "-e" (format "%s,%sp" b e) file)))

	(defvar spelunker-slave-process nil)
	(defun spelunker-eldoc-document ()
	(let* ((pos (spelunker-jump-pos))
	(file (car pos))
	(line (cdr pos)))
	(if spelunker-use-extra-emacs
	(let ((server-use-tcp nil))
	(when (not (and spelunker-slave-process
	(process-live-p spelunker-slave-process)))
	(setq spelunker-slave-process (start-process "spelunker-slave"
	nil
	"emacs" "-Q" "--eval" (format "%S" spelunker-slave-elisp)
	)))
	(server-eval-at (format "spelunker-slave:%d" (process-id spelunker-slave-process))
	`(spelunker-slave-preview ,file ,line
	,(mapconcat 'identity
	(nreverse (split-string file "/"))
	" > ")
	))

	"")
	(let ((preview-txt (spelunker-make-preview-txt file
	line
	3)))
	(save-excursion (beginning-of-line)
	(when (re-search-forward ".;\"\t\\(.\\)$"
	(line-end-position) t)
	(let ((inline (match-string 1)))
	(concat
	(if spelunker-multiline-display-mode "" inline)
	(if spelunker-multiline-display-mode "" "\n")
	(if spelunker-multiline-display-mode "" (propertize file 'face 'mode-line))
	(if spelunker-multiline-display-mode "" "\n")
	(mapconcat 'identity preview-txt "\n")
	))))))))

	(define-derived-mode spelunker-mode prog-mode "Spelunker"
	"A major mode to browsing tags file generated by ctags"
	(setq-local font-lock-defaults
	`(,(spelunker-font-lock-keywords (aget spelunker-session 'root)) t))
	(define-key spelunker-mode-map "\|" 'spelunker-query-tags)
	(define-key spelunker-mode-map "\C-\\" 'spelunker-multiline-display-mode)
	(define-key spelunker-mode-map "q" 'spelunker-tags-toggle)
	(define-key spelunker-mode-map "^" 'spelunker-goto-parent-class)
	(define-key spelunker-mode-map [return] 'spelunker-jump)
	(define-key spelunker-mode-map [kp-enter] 'spelunker-jump)
	(setq-local forward-sexp-function 'spelunker-forward-field)
	(define-key spelunker-mode-map "\C-c\C-l" 'spelunker-horizontal-reposition)
	(setq-local eldoc-documentation-function 'spelunker-eldoc-document)
	(setq-local case-fold-search nil)
	(setq-local tab-width 3)
	(turn-on-eldoc-mode)
	(hl-line-mode t)
	(setq-local truncate-lines t)
	(setq-local buffer-read-only t))
	(setq auto-mode-alist (append '(("\\.tags$" . spelunker-mode)
	("\\<tags$" . spelunker-mode))
	auto-mode-alist))
	(add-to-list 'font-lock-extra-managed-props 'invisible)
	(add-to-list 'font-lock-extra-managed-props 'display)


	(require 'compile)
	(defun compile-goto-error (&optional event)
	"Visit the source for the error message at point.
	Use this command in a compilation log buffer."
	(interactive (list last-input-event))
	(if event (posn-set-point (event-end event)))
	(or (compilation-buffer-p (current-buffer))
	(error "Not in a compilation buffer"))
	(compilation--ensure-parse (point))
	(ring-insert find-tag-marker-ring (point-marker))
	(if (get-text-property (point) 'compilation-directory)
	(dired-other-window
	(car (get-text-property (point) 'compilation-directory)))
	(setq compilation-current-error (point))
	(next-error-internal)))

	(provide 'spelunker)