spelunker.el

spelunker.el, 20161206

;;; 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)
(require 'which-func)
(require 'server)

;;
;; 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-expand-source (source)
  (if (stringp source)
      (expand-file-name source)
    (if (stringp (car source))
	(mapcar 'expand-file-name source)
      (mapcar (lambda (s)
		(cons (car s) (expand-file-name (cdr s))))
	      source))))
			   
(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 . ,(spelunker-expand-source source))
		(tags-file . ,(funcall build-filename ".tags"))
		(scratch-file . ,(funcall build-filename ".scratch"))
		(optlib-file . ,(funcall build-filename  ".ctags"))
		(change-log-file . ,(funcall build-filename ".changelog"))
		(history . [,(spelunker-branch-new t)
			    nil])
		)))
    (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))
    (setq change-log-default-name (aget spelunker-session 'change-log-file))
    (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)

;; (spelunker-reset-history)
;; (aget spelunker-session 'history)
;; (aref (aget spelunker-session 'history) 0)
;; (aref (aget spelunker-session 'history) 1)
(defun spelunker-reset-history ()
  (interactive)
  (aset (aget spelunker-session 'history) 0 (spelunker-branch-new t))
  (aset (aget spelunker-session 'history) 1 nil))

(defun spelunker-push-start ()
  ;;(ring-insert find-tag-marker-ring (point-marker))
  (spelunker-hist-call-open (aget spelunker-session 'history))
  )

(defun spelunker-push-end ()
  ;;(ring-insert find-tag-marker-ring (point-marker))
  (spelunker-hist-call-close (aget spelunker-session 'history))
  )

(defun spelunker-push-abort ()
  ;;(ring-insert find-tag-marker-ring (point-marker))
  (spelunker-hist-call-abort (aget spelunker-session 'history))
  )

(defun spelunker-pop ()
  (interactive)
  (spelunker-hist-return (aget spelunker-session 'history)))

;;
;; Global binding
;;
(define-key global-map [kp-0]         'spelunker-tags-toggle)
(define-key global-map [kp-1]         'spelunker-list-history)
(define-key global-map [S-kp-end]         'spelunker-list-branches)
(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]       'spelunker-pop)
(define-key global-map "\M-*"         'spelunker-pop)

(defun spelunker-make-scratch-here ()
  (interactive)
  (spelunker-push-start)
  (find-file (aget spelunker-session 'scratch-file))
  (spelunker-push-end))

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

;;
;;
;;
(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 (expand-file-name roots)))
     ((and (listp roots) (stringp (car roots)))
      (mapcar #'expand-file-name roots))
     ((and (listp roots) (listp (car roots)))
      (mapcar (lambda (elt)
		(expand-file-name (cdr elt)))
	      roots)))))

(defun spelunker-tags-file ()
  (let ((f (aget spelunker-session 'tags-file))
	(optlib (let ((optlib (aget spelunker-session 'optlib-file)))
		  (when (file-exists-p optlib) optlib))))
    (if (file-exists-p f)
	f
      (let ((roots (spelunker-roots))
	    (opts `(
		   "-o"
		   ,f
		   "-G"
		   "--fields=*"
		   "--extra=*-r"
		   "--kinds-*=*"
		   "--kinds-C=-lzp"
		   "--kinds-C++=-lzp"		   
		   "--kinds-Java=-l"
		   "--kinds-Python=-lz"
		   "--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)
      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))
	      (or (aget roots root)
		  (aget roots (intern 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))))
  (spelunker-push-start)
  (spelunker-tags-toggle t)
  (spelunker-search-forward (symbol-name n) nil)
  (sit-for 0)
  (spelunker-push-end)
  (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:" (file-name-base (symbol-name (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-list-file ()
  (interactive)
  (spelunker-query-tags '(eq? $kind "file")))

(defun spelunker-enter-file ()
  (interactive)
  (spelunker-query-tags '(eq? $kind "file")))

(defun spelunker-query-tags (sexp)
  (interactive "xExpression: ")
  (spelunker-push-start)
  (let* ((n (format "%s/%S"
		    (file-name-nondirectory (aget spelunker-session 'tags-file))
		    sexp))
	 (b (get-buffer n)))
    (if b
	(prog1 (pop-to-buffer b) (spelunker-push-end))
      (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))
	(spelunker-push-end)
	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)
  (spelunker-push-start)
  (let ((pos (spelunker-jump-pos)))
    (if pos
	(progn
	  (find-file (car pos))
	  (goto-line (cdr pos))
	  (spelunker-push-end))
      (spelunker-push-end)
      (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 "f" 'spelunker-list-file)
   (define-key spelunker-mode-map "i" 'spelunker-enter-file)   
   (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))
  (spelunker-push-start)
  (prog1 (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))
    (spelunker-push-end)))


(defun grep-rename-buffer ()
  (interactive)
  (let ((a (car compilation-arguments)))
    (rename-buffer
     (cond
      ((string-match "^z?grep -nH -e \\(.*\\)" a)
       (format "*grep* - %s - %s" (match-string 1 a) default-directory))
      ((string-match "^find \\. -type f -exec grep -nH -e \\(.*\\) {} \\+" a)
       (format "*grep* - %s - %s" (match-string 1 a) default-directory))
      (t
       (format "*grep* - %s - %s" a default-directory))))))


(defun spelunker-hist-gen-uuid ()
  (replace-regexp-in-string "\n$" "" (shell-command-to-string "uuidgen")))

;;
;; action: [call uuid from to]
;; branch: [given-name end-uuid start-uuid (...)]
(defun spelunker-action-uuid (action)
  (aref action 1))

(defun spelunker-branch-new (end)
  `[nil ,end nil ()])
(defun spelunker-branch-push (branch action parent-uuid)
  (aset branch 3 (cons action (aref branch 3)))
  (aset branch 2 parent-uuid))
(defun spelunker-branch-top (branch)
  (car (aref branch 3)))
(defun spelunker-branch-next-top (branch)
  (cadr (aref branch 3)))
(defun spelunker-branch-pop (branch)
  (aset branch 3 (cdr (aref branch 3))))

(defun spelunker-hist-get-pos ()
  (if (buffer-file-name)
      `(file ,(buffer-file-name)
	      ,(line-number-at-pos)
	      :function ,(which-function)
	      ,major-mode
	      )
    `(buffer ,(buffer-name) ,(line-number-at-pos)
	      ,major-mode)))

(defun spelunker-hist-goto-pos (pos)
  (cond
   ((eq (car pos) 'file)
    (progn (find-file (cadr pos))
	   (goto-line (caddr pos))))
   ((eq (car pos) 'buffer)
    (progn (switch-to-buffer (cadr pos))
	   (goto-line (caddr pos))))))

(defun spelunker-hist-call-abort (hist)
  (let ((current-branch (aref hist 0)))
    (spelunker-branch-pop current-branch)))

(defun spelunker-hist-call-open (hist)
  (let ((vec `[call ,(spelunker-hist-gen-uuid) 
		    ,(spelunker-hist-get-pos)
		    nil])
	(current-branch (aref hist 0)))
    (spelunker-branch-push current-branch vec t)
    (let* ((branches (aref hist 1))
	   (branch (car branches)))
      (when branch
	(aset hist 1 (cons nil branches))))))

(defun spelunker-hist-call-close (hist)
  (let* ((current-branch (aref hist 0))
	 (last (spelunker-branch-top current-branch)))
    (aset last 3 (spelunker-hist-get-pos))))
    
(defun spelunker-hist-return (hist)
  (let* ((current-branch (aref hist 0))
	 (parent (spelunker-branch-next-top current-branch))
	 (vec (spelunker-branch-top current-branch))
	 (marker (aref vec 2))
	 (branches (aref hist 1))
	 (branch (or (car branches)
		     (spelunker-branch-new
		      (spelunker-action-uuid vec)))))
    (spelunker-branch-push branch vec
			   (if parent
			       (spelunker-action-uuid parent)
			     t))
    (aset hist 1 (cons branch (cdr branches)))
    (spelunker-branch-pop current-branch)

    ;; Taken from etags.el
    (spelunker-hist-goto-pos marker)
    ))

;; switch-branch
;; name-current
;; reset
(defvar spelunker-branch-mode-map nil)
(defun spelunker-branch-pp (data)
  (insert (format "%s: %s - %s\n%s\n"
		  (aref data 0) (aref data 2) (aref data 1)
		  (if (< 3 (length data))
		      (pp-to-string (aref data 3))
		    ""
		    ))))
(defun spelunker-list-branches ()
  (interactive)
  (switch-to-buffer
   (generate-new-buffer (format "*branches of %s*" (aget spelunker-session 'name))))
  (kill-all-local-variables)
  (setq major-mode 'spelunker-branches
	mode-name "Spelunker Branches")
  (use-local-map spelunker-branch-mode-map)
  (erase-buffer)
  (buffer-disable-undo)
  (let ((ewoc (ewoc-create 'spelunker-branch-pp "")))
    (let ((branches (aref (aget spelunker-session 'history) 1)))
      (mapc
       #'(lambda (branch)
	   (when branch
	     (ewoc-enter-last ewoc branch))
	   )
       branches))
    ))

(defvar spelunker-history-mode-map nil)
(defun spelunker-history-pp-shorten-file-name (input roots)
  (if roots
      (let* ((root (car roots))
	     (nickname (car root))
	     (prefix (cdr root)))
	(if (string-prefix-p prefix input)
	    (let ((output (substring input (length prefix))))
	      (propertize (format "[%s] %s" nickname output)
			  'spelunker-file input)
	      )
	  (spelunker-history-pp-shorten-file-name input (cdr roots))))
    input))

(defun spelunker-history-pp (data)
  (insert (format "uuid: %s\n" (aref data 1)))
  (insert (format "type: %s\n" (aref data 0)))
  (insert (format "from: %s\n"
		  (if (eq (car (aref data 2)) 'file)
		      (let* ((root (aget spelunker-session 'root))
			     (root (if (stringp root) (list root) root))
			     (root (mapcar (lambda (r)
					     (if (stringp r) ("" . r) r))
					   root)))
			(let ((file (spelunker-history-pp-shorten-file-name
				     (cadr (aref data 2)) root)))
			  (cons 'file (cons file (cddr (aref data 2))))))
		    (aref data 2))))
  (insert (format "to: %s\n" (if (eq (car (aref data 2)) 'file)
		      (let* ((root (aget spelunker-session 'root))
			     (root (if (stringp root) (list root) root))
			     (root (mapcar (lambda (r)
					     (if (stringp r) ("" . r) r))
					   root)))
			(let ((file (spelunker-history-pp-shorten-file-name
				     (cadr (aref data 2)) root)))
			  (cons 'file (cons file (cddr (aref data 2))))))
		    (aref data 3)))))
      
(defun spelunker-list-history ()
  (interactive)
  (switch-to-buffer
   (generate-new-buffer (format "*history of %s<%s|%s|%s>*"
				(aget spelunker-session 'name)
				(aref (aref (aget spelunker-session 'history) 0) 0)
				(aref (aref (aget spelunker-session 'history) 0) 1)
				(aref (aref (aget spelunker-session 'history) 0) 2))))
  (kill-all-local-variables)
  (setq major-mode 'spelunker-history
	mode-name "Spelunker History")
  (use-local-map spelunker-history-mode-map)
  (erase-buffer)
  (buffer-disable-undo)
  (let ((ewoc (ewoc-create 'spelunker-history-pp "")))
    (let ((history (aref (aref (aget spelunker-session 'history) 0) 3)))
      (mapc
       #'(lambda (action)
	   (when action
	     (ewoc-enter-last ewoc action))
	   )
       history))))

(provide 'spelunker)

splunker.el --- 読解者のためのu-ctagsのフロントエンド

step 0.

• このソフトウェアについてバグ報告は不要です。直せそうにないので。

• このソフトウェアを導入すると従来の etags ベースの機能は使えなくなります。
  etagsで使うキーバインドを上書きするためです。

• あきらかに候補が一つでも、一旦リストへ飛びます。これは無駄に思うかもしれ
  ませんが、変えるつもりはありません。

• ctags自体の使い方など
  http://people.redhat.com/yamato/talks/reading/slides/1/12ctags-usage.pdf

step 1.

.emacs.d に spelunker.el の名前で保存して、init.elなり初期に読み込む
ファイルにて (require 'spelunker) します。

ここで失敗するようであれば、保存場所が悪いということになります。

step 2.
Universal-ctagsをビルドすると ctags と readtagss というファイルができるはずです。
これを

(defconst spelunker-readtags-command (expand-file-name "/var/ctags-github/readtags"))
(defconst spelunker-ctags-command (expand-file-name "/var/ctags-github/ctags"))

に指定します。

ディスプレイが一つしかない環境では、

(defvar spelunker-use-extra-emacs t)

を

(defvar spelunker-use-extra-emacs nil)

へ書き換えます。

step 3.

mkdir ~/.spelunker.d

を掘り、そこに _.elを作ります。ここで 調査したい ソースコードの集合を定義します。

集合定義の例:

(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")
   (mib . "/srv/sources/sources/n/net-snmp/^alias-rhel7u1/pre-build/net-snmp-5.7.2/mibs")
   ))

これで kernel, net-tools, mib と名前をつけたソースの集合を定義し、さらにその集合に
networkという名前をつけます。集合は複数作れます。

ここで _.el を開いて M-x eval-buffer します。
するとメニューに Sessions が追加されるはずです。

Sessionsから 集合の名前を選択します。上の例であれば "network"が選択対象となります。

ここで M-. を押すと、(従来と同じように)検索する名前を聞いてきます。名前を入れると
~/.spelunker.d/{名前} 以下に tagsファイルがあるかどうかを調べ、無ければ、
適当なオプションでctagsを実行して tags ファイルを作ります。そして
tagsファイルをemacsに読み込み 名前 に対するタグ情報のリストを表示します。

タグ情報を注意深く読んで、気になるエントリー上で return を押すと、
その定義個所に飛ぶはずです。ハズレだった場合は M-* でリストに戻れ
ます。

M-x spelunker-find-grep => あればgrepのバッファへ移動。もう一度
M-x spelunker-find-grep すると find-grep

M-x spelunker-dired 集合中の名前を選択して diredします。

便利なのはこれぐらい。

おまけ

インストール

gcc, make, autoconf, automakeが必要となります。

$ mkdir universal-ctags
mkdir universal-ctags
$ cd universal-ctags/
cd universal-ctags/
$ ls
ls
$ git clone https://github.com/universal-ctags/ctags.git
git clone https://github.com/universal-ctags/ctags.git
Cloning into 'ctags'...
remote: Counting objects: 17466, done.
remote: Compressing objects: 100% (5/5), done.
remote: Total 17466 (delta 0), reused 0 (delta 0), pack-reused 17461
Receiving objects: 100% (17466/17466), 5.85 MiB | 1.48 MiB/s, done.
Resolving deltas: 100% (10422/10422), done.
Checking connectivity... done.
$ cd ctags/
cd ctags/
$ bash autogen.sh
bash autogen.sh
autoreconf: Entering directory `.'
...
optlib2c: translating optlib/m4.ctags to optlib/m4.c
$ ./configure
./configure
checking for a BSD-compatible install... /usr/bin/install -c
checking whether build environment is sane... yes
checking for a thread-safe mkdir -p... /usr/bin/mkdir -p
...
checking that generated files are newer than configure... done
configure: creating ./config.status
config.status: creating Makefile
config.status: creating ctags.1
config.status: creating config.h
config.status: executing depfiles commands
$ make
make
./misc/gen-repoinfo > main/repoinfo.h
make all-am
make[1]: Entering directory '/tmp/universal-ctags/ctags'
CC main/ctags-args.o
...
CCLD readtags
make[1]: Leaving directory '/tmp/universal-ctags/ctags'
$ ls -l ctags
ls -l ctags
-rwxr-xr-x. 1 yamato yamato 1681000 1月 14 14:55 ctags
$ ln -s $(pwd)/ctags ~/bin/u-ctags

これで u-ctags で呼び出されるようになります。

標準出力への出力

"-o -" を指定するとtagsファイルを作らずに標準出力に出力できます。これでフィルターを組むことができます。

$ cd /usr/lib/python2.7/site-packages/rpmkit
$ u-ctags -o - --exclude='*.pyc' -R . | head
A tests/utils.py /^ class A(object):$/;" c function:Test_00.test_00_typecheck file:
BACKENDS updateinfo/main.py /^BACKENDS = dict(yumwrapper=rpmkit.updateinfo.yumwrapper.Base,$/;" v
Base updateinfo/base.py /^class Base(object):$/;" c
Base updateinfo/yumwrapper.py /^class Base(rpmkit.updateinfo.base.Base):$/;" c
BeautifulSoup swapi.py /^ BeautifulSoup = None$/;" v
C tests/swapi.py /^import rpmkit.tests.common as C$/;" I
C tests/yum_surrogate.py /^import rpmkit.tests.common as C$/;" I
C updateinfo/tests/dnfbase.py /^import rpmkit.tests.common as C$/;" I
C updateinfo/tests/subproc.py /^import rpmkit.tests.common as C$/;" I
C updateinfo/tests/utils.py /^import rpmkit.tests.common as C$/;" I

"--sort=no"指定すると名前順にソートするのをやめます。

$ u-ctags --sort=no -o - --exclude='*.pyc' -R . | head
E shell.py /^import rpmkit.environ as E$/;" I
U shell.py /^import rpmkit.utils as U$/;" I
MIN_TIMEOUT shell.py /^MIN_TIMEOUT = 5 # [sec]$/;" v
MAX_TIMEOUT shell.py /^MAX_TIMEOUT = 60 * 5 # 300 [sec] = 5 [min]$/;" v
_debug_mode shell.py /^def _debug_mode():$/;" f
_is_valid_timeout shell.py /^def _is_valid_timeout(timeout):$/;" f
_cleanup_process shell.py /^def _cleanup_process(pid):$/;" f
_terminate shell.py /^def _terminate(proc, wait=1):$/;" f
init shell.py /^def init(loglevel=logging.INFO):$/;" f
TaskError shell.py /^class TaskError(Exception):$/;" c

入力ファイルリスト

入力ファイル一覧を作ってファイルに保存しておき、"-L ファイル" で 指定
できます。特にファイル名を - とすると標準入力からファイルの内容を取る
ことができます。

$ find . -name '*.py' | u-ctags --sort=no -o - -L - | head
E ./shell.py /^import rpmkit.environ as E$/;" I
U ./shell.py /^import rpmkit.utils as U$/;" I
MIN_TIMEOUT ./shell.py /^MIN_TIMEOUT = 5 # [sec]$/;" v
MAX_TIMEOUT ./shell.py /^MAX_TIMEOUT = 60 * 5 # 300 [sec] = 5 [min]$/;" v
_debug_mode ./shell.py /^def _debug_mode():$/;" f
_is_valid_timeout ./shell.py /^def _is_valid_timeout(timeout):$/;" f
_cleanup_process ./shell.py /^def _cleanup_process(pid):$/;" f
_terminate ./shell.py /^def _terminate(proc, wait=1):$/;" f
init ./shell.py /^def init(loglevel=logging.INFO):$/;" f
TaskError ./shell.py /^class TaskError(Exception):$/;" c

kinds

言語ごとにどういった種類(kind)の名前を採取するかは --kind-=...
で言語毎に制御できます。に指定できる言語の一覧は
--list-languagesで一覧できます。

$ u-ctags --list-languages
...
Python
...

言語毎にkindが定義されていて、一文字の省略名が定義されています。
--list-kinds=で一覧できます。

$ u-ctags --list-kinds=Python
c classes
f functions
m class members
v variables
I name referring a module defined in other file
x name referring a classe/variable/function/module defined in other module

例えば c だけを指定すればクラスだけを抜きとれます。(Iとxは特別なので無視して下さい。)

$ find . -name '*.py' | u-ctags --kinds-Python=c --sort=no -o - -L - | head
TaskError ./shell.py /^class TaskError(Exception):$/;" c
Task ./shell.py /^class Task(object):$/;" c
Test_00_functions ./tests/shell.py /^class Test_00_functions(unittest.TestCase):$/;" c
Test_10_Task ./tests/shell.py /^class Test_10_Task(unittest.TestCase):$/;" c
Test_20_do_task ./tests/shell.py /^class Test_20_do_task(unittest.TestCase):$/;" c
Test_30_run ./tests/shell.py /^class Test_30_run(unittest.TestCase):$/;" c
Test_40_prun ./tests/shell.py /^class Test_40_prun(unittest.TestCase):$/;" c
Test_10_effectful_functions ./tests/yum_surrogate.py /^ class Test_10_effectful_functions(unittest.TestCase):$/;" c
Test_00 ./tests/utils.py /^class Test_00(unittest.TestCase):$/;" c
A ./tests/utils.py /^ class A(object):$/;" c function:Test_00.test_00_typecheck file:

出力

出力について解説します。

出力の各行は

<名前>\t<入力ファイル名>\t/<名前出現箇所のパターン>/;"\t<kind>\t<<名前>が定義されたスコープのkind:<名前>が定義されたスコープの名前>\t...

となります。

A ./tests/utils.py /^ class A(object):$/;" c function:Test_00.test_00_typecheck file:

であれば

A
名前

./tests/utils.py

入力ファイル

名前出現箇所のパターン

^        class A(object):$

<名前>が定義されたスコープのkind

function

<名前>が定義されたスコープの名前

Test_00.test_00_typecheck

fields

ctagsは名前に関連した様々な情報を採取しています。そのうちどの情報(field)を
表示するかを --fields=+... で制御します。fieldの一覧は --list-fieldsで
表示できます。

$ u-ctags --list-fields | head
N name tag name(fixed field) format-char on
F input input file(fixed field) format-char on
P pattern pattern(fixed field) format-char on
C compact compact input line(fixed field, only used in -x option) format-char off
a access Access (or export) of class members format-char off
f file File-restricted scoping format-char on
...
i inherits Inheritance information format-char off
...

例えば i を指定するとclassの継承情報が表示できます。

$ find . -name '*.py' | u-ctags --kinds-Python=c --fields=+i --sort=no -o - -L - | head
TaskError ./shell.py /^class TaskError(Exception):$/;" c inherits:Exception
Task ./shell.py /^class Task(object):$/;" c inherits:object
Test_00_functions ./tests/shell.py /^class Test_00_functions(unittest.TestCase):$/;" c inherits:unittest.TestCase
Test_10_Task ./tests/shell.py /^class Test_10_Task(unittest.TestCase):$/;" c inherits:unittest.TestCase
Test_20_do_task ./tests/shell.py /^class Test_20_do_task(unittest.TestCase):$/;" c inherits:unittest.TestCase
Test_30_run ./tests/shell.py /^class Test_30_run(unittest.TestCase):$/;" c inherits:unittest.TestCase
Test_40_prun ./tests/shell.py /^class Test_40_prun(unittest.TestCase):$/;" c inherits:unittest.TestCase
Test_10_effectful_functions ./tests/yum_surrogate.py /^ class Test_10_effectful_functions(unittest.TestCase):$/;" c inherits:unittest.TestCase
Test_00 ./tests/utils.py /^class Test_00(unittest.TestCase):$/;" c inherits:unittest.TestCase
A ./tests/utils.py /^ class A(object):$/;" c function:Test_00.test_00_typecheck file: inherits:object

inherits:が追加されました。

TaskError	./shell.py	/^class TaskError(Exception):$/;"	c	inherits:Exception

を見るとTaskErrorがExceptionから派生したことがわかります。

出力の整形

-x --_xformat=... で出力の整形をできます。--_xformat=の指定は

%[コラム幅]フィールド

という形式を取り、C言語のprintfの形式に似せてあります。ここでフィールドの
一覧は --list-fields で確認できます。

例:

$ find . -name '*.py' | u-ctags --kinds-Python=c --fields=+i --sort=no -o - -L - -x --_xformat="%-20N -- %C" | head
TaskError -- class TaskError(Exception):
Task -- class Task(object):
Test_00_functions -- class Test_00_functions(unittest.TestCase):
Test_10_Task -- class Test_10_Task(unittest.TestCase):
Test_20_do_task -- class Test_20_do_task(unittest.TestCase):
Test_30_run -- class Test_30_run(unittest.TestCase):
Test_40_prun -- class Test_40_prun(unittest.TestCase):
Test_10_effectful_functions -- class Test_10_effectful_functions(unittest.TestCase):
Test_00 -- class Test_00(unittest.TestCase):
A -- class A(object):

%-20N
20文字右寄せで tag name を出力

%C

compact input line

importの情報

--extraにrを指定すると参照タグを出力するようになります。
参照タグとして採取しているのは主に import 行です。

--extraにfを指定すると「ファイルの存在」自体をタグとして
出力します。

$ find . -name '*.py' | u-ctags --kinds-Python='IxF' --fields=+r --extra=+rf --sort=no -o - -L - -x --_xformat="%-20N [%K:%-19r] -- %F %C"

これを活用するとimportされた/した情報だけを列挙できます。

$ find . -name '*.py' | u-ctags --kinds-Python='IxF' --fields=+r --extra=+rf --sort=no -o - -L - -x --_xformat="%-20N [%K:%-19r] -- %F %C"
rpmkit [module:imported ] -- ./shell.py import rpmkit.environ as E
environ [module:indirectly-imported] -- ./shell.py import rpmkit.environ as E
E [namespace: ] -- ./shell.py import rpmkit.environ as E
rpmkit [module:imported ] -- ./shell.py import rpmkit.utils as U
utils [module:indirectly-imported] -- ./shell.py import rpmkit.utils as U
U [namespace: ] -- ./shell.py import rpmkit.utils as U
logging [module:imported ] -- ./shell.py import logging
multiprocessing [module:imported ] -- ./shell.py import multiprocessing
os [module:imported ] -- ./shell.py import os
os [module:imported ] -- ./shell.py import os.path
path [module:imported ] -- ./shell.py import os.path

--fields=+rのrは参照タグがどういった役割の存在として参照されているか(role)についても表示せよ、
という意味になります。roleの一覧は --_list-roles で確認できます。

$ u-ctags --_list-roles=Python
u-ctags --_list-roles=Python
Python i imported imported modules on
Python i namespace namespace from where classes/variables/functions are imported on
Python i indirectly-imported module imported in alternative name on
Python x imported imported from the other module on
Python x indirectly-imported classes/variables/functions/modules imported in alternative name on

iやxはkindを指します。

$ u-ctags --_list-kinds-full=Python
c class classes on referenceOnly:FALSE nRoles:0
f function functions on referenceOnly:FALSE nRoles:0
m member class members on referenceOnly:FALSE nRoles:0
v variable variables on referenceOnly:FALSE nRoles:0
I namespace name referring a module defined in other file on referenceOnly:FALSE nRoles:0
i module modules on referenceOnly:TRUE nRoles:3
x unknown name referring a classe/variable/function/module defined in other module on referenceOnly:FALSE nRoles:2

長い名前

紹介したかったのですが...pythonでは--extra=+qが実装されていませんでした。
(今実装されてるかも)