sepia-tree.el

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