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 (mapcar (lambda (x) (widget-get pw x))
  19                            '(:sepia-file :sepia-line :sepia-obj :sepia-mod))))
  20     (cond
  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
  45                (sort
  46                 (sepia-uniquify (funcall func widget))
  47                 #'sepia-tree-def-order
  48                 )))
  49           (if children
  50               (mapcar
  51                (lambda (x) (apply #'sepia-tree-node func x))
  52                children)
  53               (widget-put widget :has-children nil))))))
  54
  55 (defun sepia-tree-node (func file line obj mod)
  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 ,(format "%s::%s" mod obj)
  63            :format "%[%t%]\n"
  64            :help-echo ,(format "%s::%s -- %s:%s" mod obj file line)
  65            :notify sepia-tree-button-cb)
  66     :dynargs sepia-tree-node-cb
  67     :has-children t
  68     :sepia-obj ,obj
  69     :sepia-mod ,mod
  70     :sepia-file ,file
  71     :sepia-line ,line
  72     :sepia-func ,func))
  73
  74 (defun sepia-tree-tidy-buffer (name)
  75   "Get/create a new, tidy buffer for the tree widget."
  76   (switch-to-buffer name)
  77   (kill-all-local-variables)
  78   (setq widget-image-enable nil);; because the widget images are ugly.
  79   (let ((inhibit-read-only t))
  80     (erase-buffer))
  81   (let ((all (overlay-lists)))
  82     (mapcar #'delete-overlay (car all))
  83     (mapcar #'delete-overlay (cdr all)))
  84   (toggle-read-only 1)
  85   (view-mode -1))
  86
  87 (defun sepia-build-tree-buffer (func defs bufname)
  88   (if defs
  89       (lexical-let ((func func))
  90         (sepia-tree-tidy-buffer bufname)
  91         (with-current-buffer bufname
  92           (dolist (x defs)
  93             (apply #'widget-create
  94                    (apply #'sepia-tree-node
  95                           (lambda (widget)
  96                             (funcall func (widget-get widget :sepia-obj)
  97                                      (widget-get widget :sepia-mod)))
  98                           x)))
  99           (use-local-map (copy-keymap widget-keymap))
 100 ;;        (local-set-key "\M-." sepia-keymap)
 101           (sepia-install-keys)
 102           (let ((view-read-only nil))
 103             (toggle-read-only 1))
 104           (goto-char (point-min))
 105           (message "Type C-h m for usage information")))
 106       (message "No items for %s" bufname)))
 107
 108 ;;;###autoload
 109 (defun sepia-callee-tree (obj mod)
 110   "Create a tree view of a function's callees.
 111
 112 Pressing RET on a function's name displays its definition.  With
 113 prefix argument, RET instead visits in another window."
 114   (interactive (list (sepia-interactive-arg 'function)
 115                      (sepia-interactive-module)))
 116   (let* ((defs (xref-defs obj mod))
 117          (mod (if (= (length defs) 1) (or (fourth (car defs)) mod) "*")))
 118     (sepia-build-tree-buffer #'xref-callees defs
 119                              (format "*%s::%s callees*" mod obj))))
 120
 121 (defun sepia-caller-tree (obj mod)
 122   "Create a tree view of a function's callers.
 123
 124 Pressing RET on a function's name displays its definition.  With
 125 prefix argument, RET instead visits in another window."
 126   (interactive (list (sepia-interactive-arg 'function)
 127                      (sepia-interactive-module)))
 128   (let* ((defs (xref-defs obj mod))
 129          (mod (if (= (length defs) 1) (or (fourth (car defs)) mod) "*")))
 130     (sepia-build-tree-buffer #'xref-callees
 131                              defs
 132                              (format "*%s::%s callers*" mod obj))))
 133
 134 (defun sepia-uniquify (xs &optional test)
 135   (let ((h (make-hash-table :test (or test #'equal))))
 136     (dolist (x xs)
 137       (puthash x nil h))
 138     (hash-table-keys h)))
 139
 140 (defun sepia-tree-def-order (a b)
 141   (or (string< (fourth a) (fourth b))
 142       (and (string= (fourth a) (fourth b))
 143            (string< (third a) (third b)))))
 144
 145 ;;;###autoload
 146 (defun sepia-module-callee-tree (mod)
 147   "Display a callee tree for each of MOD's subroutines.
 148
 149 Pressing RET on a function's name displays its definition.  With
 150 prefix argument, RET instead visits in another window."
 151   (interactive (list (sepia-interactive-arg 'module)))
 152   (let ((defs (sort
 153                (sepia-uniquify
 154                 (remove-if (lambda (x)
 155                              (and (fourth x)
 156                                   (not (string= (fourth x) mod))))
 157                            (mapcan (lambda (x) (xref-defs x mod))
 158                                    (xref-apropos "" (concat "^" mod "$")))))
 159                #'sepia-tree-def-order)))
 160     (sepia-build-tree-buffer #'xref-callees defs (format "*%s subs*" mod))))
 161
 162 (provide 'sepia-tree)
 163 ;;; sepia.el ends here