gistfile1.txt

See https://gist.github.com/masatake/18ade8b1e1be07b53d228329ded4a856

spelunker.el 20170207

;;; 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-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 nil)

;; (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=*"
		   "--extras=*-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)))
    (when (file-readable-p file)
      (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)
  (when 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)
  (when 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)