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