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)