1 ;;; sepia-tree.el -- tree-widget-based calle[re] navigation
3 ;; Copyright (C) 2004 Sean O'Rourke. All rights reserved, some wrongs
4 ;; reversed. This code is distributed under the same terms as Perl
9 ;; See the README file that comes with the distribution.
14 (require 'tree-widget
)
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
))))
22 (find-file-other-window (car location
))
23 (sepia-set-found (list location
) 'function
)
25 ((widget-get widget
:sepia-shown-p
)
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
)))
33 (let ((str (apply #'sepia-extract-def location
)))
37 (widget-put widget
:sepia-shown-p
(length str
))
38 (widget-insert "\n" str
))
39 (message "(not found)")))))))
41 (defun sepia-tree-node-cb (widget &rest blah
)
42 (let ((func (widget-get widget
:sepia-func
)))
43 (or (widget-get widget
:args
)
46 (sepia-uniquify (funcall func widget
))
47 #'sepia-tree-def-order
51 (lambda (x) (apply #'sepia-tree-node func x
))
53 (widget-put widget
:has-children nil
))))))
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."
62 :tag
,(format "%s::%s" mod obj
)
64 :help-echo
,(format "%s::%s -- %s:%s" mod obj file line
)
65 :notify sepia-tree-button-cb
)
66 :dynargs sepia-tree-node-cb
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
))
81 (let ((all (overlay-lists)))
82 (mapcar #'delete-overlay
(car all
))
83 (mapcar #'delete-overlay
(cdr all
)))
87 (defun sepia-build-tree-buffer (func defs bufname
)
89 (lexical-let ((func func
))
90 (sepia-tree-tidy-buffer bufname
)
91 (with-current-buffer bufname
93 (apply #'widget-create
94 (apply #'sepia-tree-node
96 (funcall func
(widget-get widget
:sepia-obj
)
97 (widget-get widget
:sepia-mod
)))
99 (use-local-map (copy-keymap widget-keymap
))
100 ;; (local-set-key "\M-." sepia-keymap)
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
)))
109 (defun sepia-callee-tree (obj mod
)
110 "Create a tree view of a function's callees.
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
))))
121 (defun sepia-caller-tree (obj mod
)
122 "Create a tree view of a function's callers.
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
132 (format "*%s::%s callers*" mod obj
))))
134 (defun sepia-uniquify (xs &optional test
)
135 (let ((h (make-hash-table :test
(or test
#'equal
))))
138 (hash-table-keys h
)))
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
)))))
146 (defun sepia-module-callee-tree (mod)
147 "Display a callee tree for each of MOD's subroutines.
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
)))
154 (remove-if (lambda (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
))))
162 (provide 'sepia-tree
)
163 ;;; sepia.el ends here