(const :tag "Decorate color references" :colorProvider)
(const :tag "Fold regions of buffer" :foldingRangeProvider)
(const :tag "Execute custom commands" :executeCommandProvider)
- (const :tag "Inlay hints" :inlayHintProvider)))
+ (const :tag "Inlay hints" :inlayHintProvider)
+ (const :tag "Type hierarchies" :typeHierarchyProvider)
+ (const :tag "Call hierarchies" :callHierarchyProvider)))
(defcustom eglot-advertise-cancellation nil
"If non-nil, Eglot attemps to inform server of cancelled requests.
(WorkspaceSymbol (:name :kind) (:containerName :location :data))
(InlayHint (:position :label) (:kind :textEdits :tooltip :paddingLeft
:paddingRight :data))
- (InlayHintLabelPart (:value) (:tooltip :location :command)))
+ (InlayHintLabelPart (:value) (:tooltip :location :command))
+ ;; HACK! 'HierarchyItem' doesn't exist, only `CallHierarchyItem'
+ ;; and `TypeHierarchyItem'. But they're the same, so no bother.
+ (HierarchyItem (:name :kind)
+ (:tags :detail :uri :range :selectionRange :data))
+ (CallHierarchyIncomingCall (:from :fromRanges) ())
+ (CallHierarchyOutgoingCall (:to :fromRanges) ()))
"Alist (INTERFACE-NAME . INTERFACE) of known external LSP interfaces.
INTERFACE-NAME is a symbol designated by the spec as
:rangeFormatting `(:dynamicRegistration :json-false)
:rename `(:dynamicRegistration :json-false)
:inlayHint `(:dynamicRegistration :json-false)
+ :callHierarchy `(:dynamicRegistration :json-false)
+ :typeHierarchy `(:dynamicRegistration :json-false)
:publishDiagnostics (list :relatedInformation :json-false
;; TODO: We can support :codeDescription after
;; adding an appropriate UI to
(let ((warning-minimum-level :error))
(display-warning 'eglot (apply #'eglot--format format args) :warning)))
+(defun eglot--goto (range)
+ "Goto and momentarily highlight RANGE in current buffer."
+ (pcase-let ((`(,beg . ,end) (eglot-range-region range)))
+ ;; FIXME: it is very naughty to use someone else's `--'
+ ;; function, but `xref--goto-char' happens to have
+ ;; exactly the semantics we want vis-a-vis widening.
+ (xref--goto-char beg)
+ (pulse-momentary-highlight-region beg end 'highlight)))
+
(defalias 'eglot--bol
(if (fboundp 'pos-bol) #'pos-bol
(lambda (&optional n) (let ((inhibit-field-text-motion t))
:visible (eglot-server-capable :codeActionProvider)]
["Quickfix" eglot-code-action-quickfix
:visible (eglot-server-capable :codeActionProvider)]
+ "--"
+ ["Show type hierarchy" eglot-show-type-hierarchy]
+ ["Show call hierarchy" eglot-show-call-hierarchy]
"--"))
(easy-menu-define eglot-server-menu nil "Manage server communication"
(select-frame-set-input-focus (selected-frame)))
((display-buffer (current-buffer))))
(when selection
- (pcase-let ((`(,beg . ,end) (eglot-range-region selection)))
- ;; FIXME: it is very naughty to use someone else's `--'
- ;; function, but `xref--goto-char' happens to have
- ;; exactly the semantics we want vis-a-vis widening.
- (xref--goto-char beg)
- (pulse-momentary-highlight-region beg end 'highlight)))))))
+ (eglot--goto selection))))))
(t (setq success :json-false)))
`(:success ,success)))
(jit-lock-unregister #'eglot--update-hints)
(remove-overlays nil nil 'eglot--inlay-hint t))))
+\f
+;;; Call and type hierarchies
+(require 'button)
+(require 'tree-widget)
+
+(define-button-type 'eglot--hierarchy-item
+ 'follow-link t
+ 'face 'font-lock-function-name-face)
+
+(defun eglot--hierarchy-interactive (specs)
+ (let ((ans
+ (completing-read "[eglot] Direction (default both)?"
+ (cons "both" (mapcar #'cl-fourth specs))
+ nil t nil nil "both")))
+ (list
+ (cond ((equal ans "both") t)
+ (t (cl-third (cl-find ans specs :key #'cl-fourth :test #'equal)))))))
+
+(defmacro eglot--define-hierarchy-command
+ (name kind feature preparer specs)
+ `(defun ,name (direction)
+ ,(concat
+ "Show " kind " hierarchy for symbol at point.\n"
+ "DIRECTION can be:\n"
+ (cl-loop for (_ _ d e) in specs
+ concat (format " - `%s' for %s;\n" d e))
+ "or t, the default, to consider both.\n"
+ "Interactively with a prefix argument, prompt for DIRECTION.")
+ (interactive (if current-prefix-arg
+ (eglot--hierarchy-interactive ',specs)
+ (list t)))
+ (let* ((specs ',specs)
+ (specs (if (eq t direction) specs
+ (list
+ (cl-find direction specs :key #'cl-third)))))
+ (eglot--hierarchy-1
+ (format "*EGLOT %s hierarchy for %s*"
+ ,kind
+ (eglot-project-nickname (eglot--current-server-or-lose)))
+ ,feature ,preparer specs))))
+
+(eglot--define-hierarchy-command
+ eglot-show-type-hierarchy
+ "type"
+ :typeHierarchyProvider
+ :textDocument/prepareTypeHierarchy
+ ((:typeHierarchy/supertypes " ↑ " derived "supertypes" "derives from")
+ (:typeHierarchy/subtypes " ↓ " base "subtypes" "base of")))
+
+(eglot--define-hierarchy-command
+ eglot-show-call-hierarchy
+ "call"
+ :callHierarchyProvider
+ :textDocument/prepareCallHierarchy
+ ((:callHierarchy/incomingCalls " ← " incoming "incoming calls" "called by"
+ :from :fromRanges)
+ (:callHierarchy/outgoingCalls " → " base "outgoing calls" "calls"
+ :to :fromRanges)))
+
+(defvar-local eglot--hierarchy-roots nil)
+(defvar-local eglot--hierarchy-specs nil)
+
+(defun eglot--hierarchy-children (node)
+ (cl-flet ((get-them (method node)
+ (eglot--dbind ((HierarchyItem) name) node
+ (let* ((sym (intern (format "eglot--%s" method)))
+ (plist (text-properties-at 0 name))
+ (probe (cl-getf plist sym :none)))
+ (cond ((eq probe :none)
+ (let ((v (ignore-errors (jsonrpc-request
+ (eglot--current-server-or-lose) method
+ `(:item ,node)))))
+ (put-text-property 0 1 sym v name)
+ v))
+ (t probe))))))
+ (cl-loop
+ with specs = eglot--hierarchy-specs
+ for (method bullet _ _ hint key ranges) in specs
+ for resp = (get-them method node)
+ for items =
+ (cl-loop for r across resp
+ for item = (if key (plist-get r key) r)
+ collect item
+ do (eglot--dbind ((HierarchyItem) name) item
+ (put-text-property 0 1 'eglot--hierarchy-method
+ method name)
+ (put-text-property 0 1 'eglot--hierarchy-bullet
+ (propertize bullet
+ 'help-echo hint)
+ name)
+ (when ranges
+ (put-text-property 0 1 'eglot--hierarchy-call-sites
+ (plist-get r ranges)
+ name))))
+ append items)))
+
+(defvar eglot-hierarchy-label-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map button-map)
+ (define-key map [mouse-3] (eglot--mouse-call
+ #'eglot-hierarchy-center-on-node))
+ map)
+ "Keymap active in labels Eglot hierarchy buffers.")
+
+(defun eglot--hierarchy-label (node)
+ (eglot--dbind ((HierarchyItem) name uri _detail ((:range item-range))) node
+ (with-temp-buffer
+ (insert (propertize
+ (or (get-text-property
+ 0 'eglot--hierarchy-bullet name)
+ " ∘ ")
+ 'face 'shadow))
+ (insert-text-button
+ name
+ :type 'eglot--hierarchy-item
+ 'eglot--hierarchy-node node
+ 'help-echo "mouse-1, RET: goto definition, mouse-3: center on node"
+ 'keymap eglot-hierarchy-label-map
+ 'action
+ (lambda (_btn)
+ (pop-to-buffer (find-file-noselect (eglot-uri-to-path uri)))
+ (eglot--goto
+ (or
+ (elt
+ (get-text-property 0 'eglot--hierarchy-call-sites name)
+ 0)
+ item-range))))
+ (buffer-string))))
+
+(defun eglot--hierarchy-1 (name provider preparer specs)
+ (eglot-server-capable-or-lose provider)
+ (let* ((server (eglot-current-server))
+ (roots (jsonrpc-request
+ server
+ preparer
+ (eglot--TextDocumentPositionParams))))
+ (with-current-buffer (get-buffer-create name)
+ (eglot-hierarchy-mode)
+ (setq-local
+ eglot--hierarchy-roots roots
+ eglot--hierarchy-specs specs
+ eglot--cached-server server
+ buffer-read-only t
+ revert-buffer-function
+ (lambda (&rest _ignore)
+ ;; flush cache, would defeat purpose of a revert
+ (mapc (lambda (r)
+ (eglot--dbind ((HierarchyItem) name) r
+ (set-text-properties 0 1 nil name)))
+ eglot--hierarchy-roots)
+ (eglot--hierarchy-2)))
+ (eglot--hierarchy-2))))
+
+(defun eglot--hierarchy-2 ()
+ (cl-labels ((expander-for (node)
+ (lambda (_widget)
+ (mapcar
+ #'convert
+ (eglot--hierarchy-children node))))
+ (convert (node)
+ (let ((w (widget-convert
+ 'tree-widget
+ :tag (eglot--hierarchy-label node)
+ :expander (expander-for node))))
+ (widget-put w :empty-icon
+ (widget-get w :leaf-icon))
+ w)))
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (mapc (lambda (r)
+ (widget-create (convert r)))
+ eglot--hierarchy-roots)
+ (goto-char (point-min))))
+ (pop-to-buffer (current-buffer)))
+
+(define-derived-mode eglot-hierarchy-mode special-mode
+ "Eglot special" "Eglot mode for viewing hierarchies.
+\\{eglot-hierarchy-mode-map}"
+ :interactive nil)
+
+(defun eglot-hierarchy-center-on-node ()
+ "Refresh hierarchy, centering on node at point."
+ (interactive)
+ (setq-local eglot--hierarchy-roots
+ (list (get-text-property (point)
+ 'eglot--hierarchy-node)))
+ (eglot--hierarchy-2))
+
\f
;;; Hacks
;;;
projects / emacs.git / commitdiff