sepia-tree.el

   1 ;;; sepia-tree.el -- tree-widget-based calle[re] navigation
   2
   3 ;; Copyright (C) 2004-2007 Sean O'Rourke.  All rights reserved, some
   4 ;; wrongs reversed.  This code is distributed under the same terms as
   5 ;; Perl itself.
   6
   7 ;;; Commentary:
   8
   9 ;; See the README file that comes with the distribution.
  10
  11 ;;; Code:
  12
  13 (require 'tree-widget)
  14
  15 (defun sepia-tree-button-cb (widget &rest blah)
  16   (let* ((pw (widget-get widget :parent))
  17          (wid-name (widget-get widget :sepia-name))
  18          (location (and wid-name (xref-location wid-name))))
  19     (cond
  20       ((not location) (error "Can't find %s." wid-name))
  21       (current-prefix-arg
  22        (find-file-other-window (car location))
  23        (sepia-set-found (list location) 'function)
  24        (sepia-next))
  25       ((widget-get widget :sepia-shown-p)
  26        (save-excursion
  27          (end-of-line)
  28          (let ((inhibit-read-only t))
  29            (delete-region (point)
  30                           (+ 1 (point) (widget-get widget :sepia-shown-p))))
  31          (widget-put widget :sepia-shown-p nil)))
  32       (t
  33        (let ((str (apply #'sepia-extract-def location)))
  34          (if str
  35              (save-excursion
  36                (end-of-line)
  37                (widget-put widget :sepia-shown-p (length str))
  38                (widget-insert "\n" str))
  39              (message "(not found)")))))))
  40
  41 (defun sepia-tree-node-cb (widget &rest blah)
  42   (let ((func (widget-get widget :sepia-func)))
  43     (or (widget-get widget :args)
  44         (let ((children (funcall func widget)))
  45           (if children
  46               (mapcar
  47                (lambda (x) (sepia-tree-node func x))
  48                children)
  49               (widget-put widget :has-children nil))))))
  50
  51 (defun sepia-tree-node (func name)
  52   "Make a tree node for the object specified by FILE, LINE, OBJ,
  53 and MOD.  The new node will have a property :sepia-X
  54 corresponding to each of these values.  FUNC is a function that
  55 will, given a widget, generate its children."
  56   `(tree-widget
  57     :node (push-button
  58            :tag ,name
  59            :format "%[%t%]\n"
  60            :notify sepia-tree-button-cb)
  61     :dynargs sepia-tree-node-cb
  62     :has-children t
  63     :sepia-name ,name
  64     :sepia-func ,func))
  65
  66 (defun sepia-tree-tidy-buffer (name)
  67   "Get/create a new, tidy buffer for the tree widget."
  68   (switch-to-buffer name)
  69   (kill-all-local-variables)
  70   (setq widget-image-enable nil);; because the widget images are ugly.
  71   (let ((inhibit-read-only t))
  72     (erase-buffer))
  73   (let ((all (overlay-lists)))
  74     (mapcar #'delete-overlay (car all))
  75     (mapcar #'delete-overlay (cdr all)))
  76   (toggle-read-only 1)
  77   (view-mode -1))
  78
  79 (defun sepia-build-tree-buffer (func defs bufname)
  80   (if defs
  81       (lexical-let ((func func))
  82         (sepia-tree-tidy-buffer bufname)
  83         (with-current-buffer bufname
  84           (dolist (x defs)
  85             (apply #'widget-create
  86                    (sepia-tree-node
  87                     (lambda (widget)
  88                       (funcall func (widget-get widget :sepia-name)))
  89                     x)))
  90           (use-local-map (copy-keymap widget-keymap))
  91 ;;        (local-set-key "\M-." sepia-keymap)
  92           (sepia-install-keys)
  93           (let ((view-read-only nil))
  94             (toggle-read-only 1))
  95           (goto-char (point-min))
  96           (message "Type C-h m for usage information")))
  97       (message "No items for %s" bufname)))
  98
  99 ;;;###autoload
 100 (defun sepia-callee-tree (name)
 101   "Create a tree view of a function's callees.
 102
 103 Pressing RET on a function's name displays its definition.  With
 104 prefix argument, RET instead visits in another window."
 105   (interactive (let ((func (sepia-interactive-arg 'function))
 106                      (mod (sepia-interactive-module)))
 107                  (list (if mod (format "%s::%s" mod func)
 108                            func))))
 109   (let* ((defs (xref-apropos name)))
 110     (sepia-build-tree-buffer
 111      #'xref-callees
 112      defs
 113      (format "*%s callees*" name))))
 114
 115 (defun sepia-caller-tree (name)
 116   "Create a tree view of a function's callers.
 117
 118 Pressing RET on a function's name displays its definition.  With
 119 prefix argument, RET instead visits in another window."
 120   (interactive (let ((func (sepia-interactive-arg 'function))
 121                      (mod (sepia-interactive-module)))
 122                  (list (if mod (format "%s::%s" mod func)
 123                            func))))
 124   (let* ((defs (xref-apropos name)))
 125     (sepia-build-tree-buffer
 126      #'xref-callers
 127      defs (format "*%s callers*" name))))
 128
 129 ;;;###autoload
 130 (defun sepia-module-callee-tree (mod)
 131   "Display a callee tree for each of MOD's subroutines.
 132
 133 Pressing RET on a function's name displays its definition.  With
 134 prefix argument, RET instead visits in another window."
 135   (interactive (list (sepia-interactive-arg 'module)))
 136   (let ((defs (xref-mod-subs mod)))
 137     (sepia-build-tree-buffer #'xref-callees defs (format "*%s subs*" mod))))
 138
 139 (provide 'sepia-tree)
 140 ;;; sepia.el ends here