sepia-tree.el

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