;;; sepia-tree.el -- tree-widget-based calle[re] navigation

;; Copyright (C) 2004-2008 Sean O'Rourke.  All rights reserved, some
;; wrongs reversed.  This code is distributed under the same terms as
;; Perl itself.

;;; Commentary:

;; See the README file that comes with the distribution.

;;; Code:

(require 'tree-widget)
(require 'cl)

(defvar sepia-tree-use-image nil
  "*If non-nil, show tree-widget with icons.")

(defun sepia-tree-button-cb (widget &rest blah)
  (let* ((pw (widget-get widget :parent))
         (wid-name (widget-get pw :sepia-name))
         (location (and wid-name (car (xref-location wid-name)))))
    (cond
      ((not location) (error "Can't find %s." wid-name))
      (current-prefix-arg
       (find-file-other-window (car location))
       (sepia-set-found (list location) 'function)
       (sepia-next))
      ((widget-get widget :sepia-shown-p)
       (save-excursion
	 (end-of-line)
	 (let ((inhibit-read-only t))
	   (delete-region (point)
			  (+ 1 (point) (widget-get widget :sepia-shown-p))))
	 (widget-put widget :sepia-shown-p nil)))
      (t
       (let ((str (apply #'sepia-extract-def location)))
	 (if str
	     (save-excursion
	       (end-of-line)
	       (widget-put widget :sepia-shown-p (length str))
	       (widget-insert "\n" str))
	     (message "(not found)")))))))

(defun sepia-tree-node-cb (widget &rest blah)
  (let ((func (widget-get widget :sepia-func)))
    (or (widget-get widget :args)
	(let ((children (funcall func widget)))
	  (if children
	      (mapcar
	       (lambda (x) (sepia-tree-node func x))
	       children)
	      (widget-put widget :has-children nil))))))

(defun sepia-tree-node (func name)
  "Make a tree node for the object specified by FILE, LINE, OBJ,
and MOD.  The new node will have a property :sepia-X
corresponding to each of these values.  FUNC is a function that
will, given a widget, generate its children."
  `(tree-widget
    :node (push-button
	   :tag ,name
	   :format "%[%t%]\n"
	   :notify sepia-tree-button-cb)
    :dynargs sepia-tree-node-cb
    :has-children t
    :sepia-name ,name
    :sepia-func ,func))

(defun sepia-tree-tidy-buffer (name)
  "Get/create a new, tidy buffer for the tree widget."
  (switch-to-buffer name)
  (kill-all-local-variables)
  ;; because the widget images are ugly.
  (set (make-local-variable 'widget-image-enable) sepia-tree-use-image)
  (let ((inhibit-read-only t))
    (erase-buffer))
  (let ((all (overlay-lists)))
    (mapcar #'delete-overlay (car all))
    (mapcar #'delete-overlay (cdr all)))
  (toggle-read-only 1)
  (view-mode -1))

(defun sepia-build-tree-buffer (func defs bufname)
  (if defs
      (lexical-let ((func func))
        (sepia-tree-tidy-buffer bufname)
        (with-current-buffer bufname
          (dolist (x defs)
            (widget-create
                   (sepia-tree-node
                    (lambda (widget)
                      (funcall func (widget-get widget :sepia-name)))
                    x)))
          (use-local-map (copy-keymap widget-keymap))
;;        (local-set-key "\M-." sepia-keymap)
;;        (sepia-install-keys)
          (let ((view-read-only nil))
            (toggle-read-only 1))
          (goto-char (point-min))
	  (message "Type C-h m for usage information")))
      (message "No items for %s" bufname)))

;;;###autoload
(defun sepia-callee-tree (name)
  "Create a tree view of a function's callees.

Pressing RET on a function's name displays its definition.  With
prefix argument, RET instead visits in another window."
  (interactive (let ((func (sepia-interactive-arg 'function))
                     (mod (sepia-interactive-module)))
                 (list (if mod (format "%s::%s" mod func)
                           func))))
  (let* ((defs (xref-apropos name)))
    (sepia-build-tree-buffer
     #'xref-callees
     defs
     (format "*%s callees*" name))))

(defun sepia-caller-tree (name)
  "Create a tree view of a function's callers.

Pressing RET on a function's name displays its definition.  With
prefix argument, RET instead visits in another window."
  (interactive (let ((func (sepia-interactive-arg 'function))
                     (mod (sepia-interactive-module)))
                 (list (if mod (format "%s::%s" mod func)
                           func))))
  (let* ((defs (xref-apropos name)))
    (sepia-build-tree-buffer
     #'xref-callers
     defs (format "*%s callers*" name))))

;;;###autoload
(defun sepia-module-callee-tree (mod)
  "Display a callee tree for each of MOD's subroutines.

Pressing RET on a function's name displays its definition.  With
prefix argument, RET instead visits in another window."
  (interactive (list (sepia-interactive-arg 'module)))
  (let ((defs (xref-mod-subs mod)))
    (sepia-build-tree-buffer #'xref-callees defs (format "*%s subs*" mod))))

(provide 'sepia-tree)
;;; sepia.el ends here