-
Notifications
You must be signed in to change notification settings - Fork 13
/
Copy pathlspce-calltree.el
152 lines (139 loc) · 6.63 KB
/
lspce-calltree.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
;;; lspce.el --- LSP Client for Emacs -*- lexical-binding: t; -*-
(require 'lspce-core)
(require 'lspce-util)
(require 'seq)
(require 'hierarchy)
(require 'button)
(require 'compile) ;; compilation-info-face, compilation-line-face
(defcustom lspce-call-hierarchy-call-site nil
"If t, jump to the first call site instead of the start
of the surrounding function when clicking."
:type 'boolean)
(defcustom lspce-call-hierarchy-show-position nil
"If t, show where the incoming or outgoing call comes from."
:type 'boolean)
(defvar lspce--incoming-call-buffer-name "*Lspce incoming call*")
(defvar lspce--outgoing-call-buffer-name "*Lspce outgoing call*")
(defun lspce--prepare-call-hierarchy ()
(if (lspce--server-capable-chain "callHierarchyProvider")
(lspce--request "textDocument/prepareCallHierarchy" (lspce--make-textDocumentPositionParams))
(lspce--warn "Server does not support call hierarchy.")
nil))
(define-button-type 'lspce-call-hierarchy-button
'follow-link t ; Click via mouse
'face 'default)
(defun lspce--call-hierarchy-open-file (file)
(select-window (get-mru-window (selected-frame) nil :not-selected))
(find-file file))
(defun lspce--call-hierarchy-next-line ()
(interactive)
(when (= (forward-line 1) 1)
(goto-char (point-min)))
(goto-char (line-beginning-position))
(skip-chars-forward "^a-zA-Z_"))
(defun lspce--call-hierarchy-previous-line ()
(interactive)
(when (= (forward-line -1) -1)
(goto-char (point-max)))
(goto-char (line-beginning-position))
(skip-chars-forward "^a-zA-Z_"))
;; learn some skills from https://github.com/dolmens/eglot-hierarchy
(defun lspce--hierarchy-calls (direction)
"Fetch incoming calls to current symbol.
DIRECTION should be 'incoming or 'outgoing."
(let* ((root (lspce--prepare-call-hierarchy))
(root-nodes (seq-map (lambda (node) `(:item ,node)) root))
(tree (hierarchy-new))
(root-uri lspce--root-uri)
(lsp-type lspce--lsp-type)
(method (if (eq direction 'incoming)
"callHierarchy/incomingCalls"
"callHierarchy/outgoingCalls"))
(tag (if (eq direction 'incoming)
"from"
"to"))
(buffer-name (if (eq direction 'incoming)
lspce--incoming-call-buffer-name
lspce--outgoing-call-buffer-name)))
(if (length> root 0)
(progn
(hierarchy-add-trees
tree
root-nodes
nil
(lambda (node)
(let* ((item (plist-get node :item)))
(condition-case err
(let* ((response (lspce--request method (list :item item) nil root-uri lsp-type))
children)
(setq children (seq-map (lambda (item)
`(:item ,(gethash tag item)
:fromRanges ,(gethash "fromRanges" item)))
response))
children)
((error user-error)
(lspce--error "Failed to invoke %s, %s" method err)))))
nil
t)
(pop-to-buffer
(hierarchy-tree-display
tree
(lambda (node _)
(let* ((item (plist-get node :item))
(fromRanges (plist-get node :fromRanges))
(label "")
name range filename selectionRange)
(setq name (gethash "name" item)
filename (lspce--uri-to-path (gethash "uri" item))
range (gethash "range" item)
selectionRange (gethash "selectionRange" item))
(if lspce-call-hierarchy-show-position
(let ((rname filename)
(line (when-let* ((start (gethash "start" selectionRange)))
(or (gethash "line" start) 0))))
(when (string-prefix-p (lspce--uri-to-path root-uri) rname)
(setq rname (string-replace (lspce--uri-to-path root-uri) "" rname))
(when (string-prefix-p "/" rname)
(setq rname (substring-no-properties rname 1))))
(setq rname (propertize rname 'face compilation-info-face))
(setq line (propertize (format "%s" line) 'face compilation-line-face))
(setq label (format "%s %s:%s" name rname line)))
(setq label name))
(insert-text-button label
:type 'lspce-call-hierarchy-button
'action (lambda (btn)
;; FIXME select-window may fail
(let ((w (get-buffer-window (marker-buffer btn))))
(when w
(select-window w)))
(lspce--call-hierarchy-open-file filename)
(let (jump-range)
(if (and lspce-call-hierarchy-call-site)
(setq jump-range selectionRange)
(setq jump-range range))
(goto-char (lspce--lsp-position-to-point
(gethash "start" jump-range))))))))
(get-buffer-create buffer-name)))
(with-current-buffer buffer-name
(keymap-local-set (kbd "h") #'backward-char)
(keymap-local-set (kbd "l") #'forward-char)
(keymap-local-set (kbd "b") #'backward-char)
(keymap-local-set (kbd "f") #'forward-char)
(keymap-local-set (kbd "n") #'lspce--call-hierarchy-next-line)
(keymap-local-set (kbd "p") #'lspce--call-hierarchy-previous-line)
(keymap-local-set (kbd "j") #'lspce--call-hierarchy-next-line)
(keymap-local-set (kbd "k") #'lspce--call-hierarchy-previous-line)
(goto-char (point-min))
(widget-button-press (point))))
(lspce--warn "No incoming call hierachy under point."))))
;;;###autoload
(defun lspce-incoming-calls ()
"Fetch incoming calls to current symbol."
(interactive)
(lspce--hierarchy-calls 'incoming))
;;;###autoload
(defun lspce-outgoing-calls ()
"Fetch outgoing calls from current symbol."
(interactive)
(lspce--hierarchy-calls 'outgoing))
(provide 'lspce-calltree)