spelunker.el, 20160312

;;; 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
;;
(defconst spelunker-readtags-command (expand-file-name "~/var/ctags-github/readtags"))
(defconst spelunker-ctags-command    (expand-file-name "~/var/ctags-github/ctags"))
(defconst spelunker-slave-elisp (expand-file-name "~/.emacs.d/spelunker-slave.el"))

(defvar spelunker-session
  `((root . "/srv/sources7/cradles/rhel-6-server-rhevm-3.5-source-rpms/sources/r/rhevm/3.5.6.2-0.1.el6ev--srpm/pre-build/ovirt-engine")
    (tags-file . ,(expand-file-name "~/rhev.tags"))
    (memo-file . ,(expand-file-name "~/memo"))
    (slave     . 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 [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-memo-here)
(define-key global-map [kp-add]       'pop-tag-mark)

(defun spelunker-make-memo-here ()
  (interactive)
  (ring-insert find-tag-marker-ring (point-marker))
  (find-file (aget spelunker-session 'memo-file)))
  
;;
;;
;;
(require 'etags)

(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)))
    (if (file-exists-p f)
	f
      (let ((roots (spelunker-roots))
	    (opts (list
		   "-o"
		   f
		   "-R"
		   "--fields=*"
		   "--extra=*"
		   "--kinds-*=*"
		   "--kinds-C=-l"
		   "--kinds-Java=-l"
		   "--excmd=mixed"
		   "-R")))
	(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)))
    (cond
     ((stringp roots)
      (aget spelunker-session roots))
     ((listp roots)
      (let ((root (completing-read "Root: "
				   (if (listp (car roots))
				       (mapcar #'car roots)
				     roots))))
	(let ((root (if (equal "" root)
			(car (if (listp (car roots))
				 (mapcar #'car roots)
			       roots))
		      root)))
	  (if (listp (car roots))
	      (aget roots root)
	    root)))))))

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

(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 "rhev.tags/%S" 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
	(progn
	  (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 (aget spelunker-session 'slave)
	(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" "-l" 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)

(provide 'spelunker)