lsp-headerline.el (21976B)
1 ;;; lsp-headerline.el --- LSP headerline features -*- lexical-binding: t; -*- 2 ;; 3 ;; Copyright (C) 2020 emacs-lsp maintainers 4 ;; 5 ;; This program is free software; you can redistribute it and/or modify 6 ;; it under the terms of the GNU General Public License as published by 7 ;; the Free Software Foundation, either version 3 of the License, or 8 ;; (at your option) any later version. 9 10 ;; This program is distributed in the hope that it will be useful, 11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 ;; GNU General Public License for more details. 14 15 ;; You should have received a copy of the GNU General Public License 16 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 17 ;; 18 ;;; Commentary: 19 ;; 20 ;; LSP headerline features 21 ;; 22 ;;; Code: 23 24 (require 'lsp-icons) 25 (require 'lsp-mode) 26 27 (defgroup lsp-headerline nil 28 "LSP support for headerline" 29 :prefix "lsp-headerline-" 30 :group 'lsp-mode 31 :tag "LSP Headerline") 32 33 (defcustom lsp-headerline-breadcrumb-segments '(path-up-to-project file symbols) 34 "Segments used in breadcrumb text on headerline." 35 :type '(repeat 36 (choice (const :tag "Include the project name." project) 37 (const :tag "Include the open file name." file) 38 (const :tag "Include the directories up to project." path-up-to-project) 39 (const :tag "Include document symbols if server supports it." symbols))) 40 :group 'lsp-headerline) 41 42 (defcustom lsp-headerline-breadcrumb-enable-symbol-numbers nil 43 "Whether to label symbols with numbers on the breadcrumb." 44 :type 'boolean 45 :group 'lsp-headerline) 46 47 (defcustom lsp-headerline-breadcrumb-enable-diagnostics t 48 "If non-nil, apply different face on the breadcrumb based on the errors." 49 :type 'boolean 50 :group 'lsp-headerline 51 :package-version '(lsp-mode . "8.0.0")) 52 53 (defface lsp-headerline-breadcrumb-separator-face '((t :inherit shadow :height 0.8)) 54 "Face used for breadcrumb separator on headerline." 55 :group 'lsp-headerline) 56 57 (defface lsp-headerline-breadcrumb-path-face '((t :inherit font-lock-string-face)) 58 "Face used for breadcrumb paths on headerline." 59 :group 'lsp-headerline) 60 61 (defface lsp-headerline-breadcrumb-path-error-face 62 '((t :underline (:style wave :color "Red1") 63 :inherit lsp-headerline-breadcrumb-path-face)) 64 "Face used for breadcrumb paths on headerline when there is an error under 65 that path" 66 :group 'lsp-headerline) 67 68 (defface lsp-headerline-breadcrumb-path-warning-face 69 '((t :underline (:style wave :color "Yellow") 70 :inherit lsp-headerline-breadcrumb-path-face)) 71 "Face used for breadcrumb paths on headerline when there is an warning under 72 that path" 73 :group 'lsp-headerline) 74 75 (defface lsp-headerline-breadcrumb-path-info-face 76 '((t :underline (:style wave :color "Green") 77 :inherit lsp-headerline-breadcrumb-path-face)) 78 "Face used for breadcrumb paths on headerline when there is an info under 79 that path" 80 :group 'lsp-headerline) 81 82 (defface lsp-headerline-breadcrumb-path-hint-face 83 '((t :underline (:style wave :color "Green") 84 :inherit lsp-headerline-breadcrumb-path-face)) 85 "Face used for breadcrumb paths on headerline when there is an hint under that 86 path" 87 :group 'lsp-headerline) 88 89 (defface lsp-headerline-breadcrumb-project-prefix-face 90 '((t :inherit font-lock-string-face :weight bold)) 91 "Face used for breadcrumb prefix on headerline. 92 Only if `lsp-headerline-breadcrumb-prefix` is `project-name-only`." 93 :group 'lsp-headerline) 94 95 (defface lsp-headerline-breadcrumb-unknown-project-prefix-face 96 '((t :inherit shadow :weight bold)) 97 "Face used for breadcrumb prefix on headerline. 98 Only if `lsp-headerline-breadcrumb-prefix` is `project-name-only`." 99 :group 'lsp-headerline) 100 101 (defface lsp-headerline-breadcrumb-symbols-face 102 '((t :inherit font-lock-doc-face :weight bold)) 103 "Face used for breadcrumb symbols text on headerline." 104 :group 'lsp-headerline) 105 106 (defface lsp-headerline-breadcrumb-symbols-error-face 107 '((t :inherit lsp-headerline-breadcrumb-symbols-face 108 :underline (:style wave :color "Red1"))) 109 "Face used for breadcrumb symbols text on headerline when there 110 is an error in symbols range." 111 :group 'lsp-headerline) 112 113 (defface lsp-headerline-breadcrumb-symbols-warning-face 114 '((t :inherit lsp-headerline-breadcrumb-symbols-face 115 :underline (:style wave :color "Yellow"))) 116 "Face used for breadcrumb symbols text on headerline when there 117 is an warning in symbols range." 118 :group 'lsp-headerline) 119 120 (defface lsp-headerline-breadcrumb-symbols-info-face 121 '((t :inherit lsp-headerline-breadcrumb-symbols-face 122 :underline (:style wave :color "Green"))) 123 "Face used for breadcrumb symbols text on headerline when there 124 is an info in symbols range." 125 :group 'lsp-headerline) 126 127 (defface lsp-headerline-breadcrumb-symbols-hint-face 128 '((t :inherit lsp-headerline-breadcrumb-symbols-face 129 :underline (:style wave :color "Green"))) 130 "Face used for breadcrumb symbols text on headerline when there 131 is an hints in symbols range." 132 :group 'lsp-headerline) 133 134 (defface lsp-headerline-breadcrumb-deprecated-face 135 '((t :inherit lsp-headerline-breadcrumb-symbols-face 136 :strike-through t)) 137 "Face used on breadcrumb deprecated text on modeline." 138 :group 'lsp-headerline) 139 140 (defvar lsp-headerline-arrow nil 141 "Holds the current breadcrumb string on headerline.") 142 143 (defvar-local lsp-headerline--path-up-to-project-segments nil 144 "Holds the current breadcrumb path-up-to-project segments for 145 caching purposes.") 146 147 (defvar-local lsp-headerline--cached-workspace-root nil 148 "Holds the current value of lsp-workspace-root for caching purposes") 149 150 ;; Redefine local vars of `all-the-icons' to avoid bytecode compilation errors. 151 (defvar all-the-icons-default-adjust) 152 (defvar all-the-icons-scale-factor) 153 154 (defun lsp-headerline--arrow-icon () 155 "Build the arrow icon for headerline breadcrumb." 156 (or 157 lsp-headerline-arrow 158 (setq lsp-headerline-arrow (let ((all-the-icons-scale-factor 1.0) 159 (all-the-icons-default-adjust 0)) 160 (lsp-icons-all-the-icons-icon 161 'material 162 "chevron_right" 163 'lsp-headerline-breadcrumb-separator-face 164 ">" 165 'headerline-breadcrumb))))) 166 167 (lsp-defun lsp-headerline--symbol-icon ((&DocumentSymbol :kind)) 168 "Build the SYMBOL icon for headerline breadcrumb." 169 (concat (lsp-icons-get-by-symbol-kind kind 'headerline-breadcrumb) 170 " ")) 171 172 (lsp-defun lsp-headerline--go-to-symbol ((&DocumentSymbol 173 :selection-range (&RangeToPoint :start selection-start) 174 :range (&RangeToPoint :start narrowing-start 175 :end narrowing-end))) 176 "Go to breadcrumb symbol. 177 If the buffer is narrowed and the target symbol lies before the 178 minimum reachable point in the narrowed buffer, then widen and 179 narrow to the outer symbol." 180 (when (buffer-narrowed-p) 181 (narrow-to-region 182 (min (point-min) narrowing-start) 183 (max (point-max) narrowing-end))) 184 (goto-char selection-start)) 185 186 (lsp-defun lsp-headerline--narrow-to-symbol ((&DocumentSymbol :range (&RangeToPoint :start :end))) 187 "Narrow to breadcrumb symbol range." 188 (narrow-to-region start end)) 189 190 (defun lsp-headerline--with-action (local-map help-echo-string display-string) 191 "Assign LOCAL-MAP and HELP-ECHO-STRING to the region around the 192 DISPLAY-STRING." 193 (propertize display-string 194 'mouse-face 'header-line-highlight 195 'help-echo help-echo-string 196 'local-map local-map)) 197 198 (defmacro lsp-headerline--make-mouse-handler (&rest body) 199 "Making mouse event handler. 200 Switch to current mouse interacting window before doing BODY." 201 (declare (debug t) (indent 0)) 202 `(lambda (event) 203 (interactive "e") 204 (select-window (posn-window (elt event 1))) 205 ,@body)) 206 207 (defun lsp-headerline--directory-with-action (full-path directory-display-string) 208 "Build action for FULL-PATH and DIRECTORY-DISPLAY-STRING." 209 (lsp-headerline--with-action (let ((map (make-sparse-keymap))) 210 (define-key map [header-line mouse-1] 211 (lsp-headerline--make-mouse-handler 212 (dired full-path))) 213 (define-key map [header-line mouse-2] 214 (lsp-headerline--make-mouse-handler 215 (dired-other-window full-path))) 216 map) 217 (format "mouse-1: browse '%s' with Dired\nmouse-2: browse '%s' with Dired in other window" 218 directory-display-string 219 directory-display-string) 220 (propertize directory-display-string 221 'lsp-full-path full-path))) 222 223 (declare-function evil-set-jump "ext:evil-jumps") 224 225 (lsp-defun lsp-headerline--symbol-with-action ((symbol &as &DocumentSymbol :name) symbol-display-string) 226 "Build action for SYMBOL and SYMBOL-STRING." 227 (lsp-headerline--with-action (let ((map (make-sparse-keymap))) 228 (define-key map [header-line mouse-1] 229 (lsp-headerline--make-mouse-handler 230 (when (bound-and-true-p evil-mode) 231 (evil-set-jump)) 232 (lsp-headerline--go-to-symbol symbol))) 233 (define-key map [header-line mouse-2] 234 (lsp-headerline--make-mouse-handler 235 (-let (((&DocumentSymbol :range (&RangeToPoint :start :end)) symbol)) 236 (if (and (eq (point-min) start) (eq (point-max) end)) 237 (widen) 238 (lsp-headerline--narrow-to-symbol symbol))))) 239 map) 240 (format "mouse-1: go to '%s' symbol\nmouse-2: %s" 241 name 242 (-let (((&DocumentSymbol :range (&RangeToPoint :start :end)) symbol)) 243 (if (and (eq (point-min) start) (eq (point-max) end)) 244 "widen" 245 (format "narrow to '%s' range" name)))) 246 symbol-display-string)) 247 248 (defun lsp-headerline--path-up-to-project-root (root-path path) 249 "Find recursively the folders until the project ROOT-PATH. 250 PATH is the current folder to be checked." 251 (let ((current-path path) 252 headerline-path-components) 253 (while (not (lsp-f-same? root-path current-path)) 254 (push (lsp-headerline--directory-with-action current-path 255 (f-filename current-path)) 256 headerline-path-components) 257 (setq current-path (lsp-f-parent current-path))) 258 headerline-path-components)) 259 260 (defun lsp-headerline--build-project-string () 261 "Build the project-segment string for the breadcrumb." 262 (-if-let (root (lsp-headerline--workspace-root)) 263 (propertize (lsp-headerline--directory-with-action 264 root 265 (f-filename root)) 266 'font-lock-face 267 'lsp-headerline-breadcrumb-project-prefix-face) 268 (propertize "<unknown>" 269 'font-lock-face 270 'lsp-headerline-breadcrumb-unknown-project-prefix-face))) 271 272 (defun lsp-headerline--build-file-string () 273 "Build the file-segment string for the breadcrumb." 274 (let* ((file-path (or (buffer-file-name) "")) 275 (filename (f-filename file-path))) 276 (if-let* ((file-ext (f-ext file-path))) 277 (concat (lsp-icons-get-by-file-ext file-ext 'headerline-breadcrumb) 278 " " 279 (propertize filename 280 'font-lock-face 281 (lsp-headerline--face-for-path file-path))) 282 filename))) 283 284 285 (defun lsp-headerline--face-for-path (dir) 286 "Calculate the face for DIR." 287 (if-let* ((diags (lsp-diagnostics-stats-for (directory-file-name dir)))) 288 (cl-labels ((check-severity 289 (severity) 290 (not (zerop (aref diags severity))))) 291 (cond 292 ((not lsp-headerline-breadcrumb-enable-diagnostics) 293 'lsp-headerline-breadcrumb-path-face) 294 ((check-severity lsp/diagnostic-severity-error) 295 'lsp-headerline-breadcrumb-path-error-face) 296 ((check-severity lsp/diagnostic-severity-warning) 297 'lsp-headerline-breadcrumb-path-warning-face) 298 ((check-severity lsp/diagnostic-severity-information) 299 'lsp-headerline-breadcrumb-path-info-face) 300 ((check-severity lsp/diagnostic-severity-hint) 301 'lsp-headerline-breadcrumb-path-hint-face) 302 (t 'lsp-headerline-breadcrumb-path-face))) 303 'lsp-headerline-breadcrumb-path-face)) 304 305 (defun lsp-headerline--severity-level-for-range (range) 306 "Get the severity level for RANGE." 307 (let ((range-severity 10)) 308 (mapc (-lambda ((&Diagnostic :range (&Range :start) :severity?)) 309 (when (lsp-point-in-range? start range) 310 (setq range-severity (min range-severity severity?)))) 311 (lsp--get-buffer-diagnostics)) 312 range-severity)) 313 314 (defun lsp-headerline--build-path-up-to-project-string () 315 "Build the path-up-to-project segment for the breadcrumb." 316 (if-let* ((root (lsp-headerline--workspace-root))) 317 (let ((segments (or 318 lsp-headerline--path-up-to-project-segments 319 (setq lsp-headerline--path-up-to-project-segments 320 (lsp-headerline--path-up-to-project-root 321 root 322 (lsp-f-parent (buffer-file-name))))))) 323 (mapconcat (lambda (next-dir) 324 (propertize next-dir 325 'font-lock-face 326 (lsp-headerline--face-for-path 327 (get-text-property 328 0 'lsp-full-path next-dir)))) 329 segments 330 (concat " " (lsp-headerline--arrow-icon) " "))) 331 "")) 332 333 (lsp-defun lsp-headerline--face-for-symbol ((&DocumentSymbol :deprecated? 334 :range)) 335 "Get the face for SYMBOL." 336 (let ((range-severity (lsp-headerline--severity-level-for-range range))) 337 (cond 338 (deprecated? 'lsp-headerline-breadcrumb-deprecated-face) 339 ((not lsp-headerline-breadcrumb-enable-diagnostics) 340 'lsp-headerline-breadcrumb-symbols-face) 341 ((= range-severity lsp/diagnostic-severity-error) 342 'lsp-headerline-breadcrumb-symbols-error-face) 343 ((= range-severity lsp/diagnostic-severity-warning) 344 'lsp-headerline-breadcrumb-symbols-warning-face) 345 ((= range-severity lsp/diagnostic-severity-information) 346 'lsp-headerline-breadcrumb-symbols-info-face) 347 ((= range-severity lsp/diagnostic-severity-hint) 348 'lsp-headerline-breadcrumb-symbols-hint-face) 349 (t 'lsp-headerline-breadcrumb-symbols-face)))) 350 351 (defun lsp-headerline--build-symbol-string () 352 "Build the symbol segment for the breadcrumb." 353 (if (lsp-feature? "textDocument/documentSymbol") 354 (-if-let* ((lsp--document-symbols-request-async t) 355 (symbols (lsp--get-document-symbols)) 356 (symbols-hierarchy (lsp--symbols->document-symbols-hierarchy symbols)) 357 (enumerated-symbols-hierarchy 358 (-map-indexed (lambda (index elt) 359 (cons elt (1+ index))) 360 symbols-hierarchy))) 361 (mapconcat 362 (-lambda (((symbol &as &DocumentSymbol :name) 363 . index)) 364 (let* ((symbol2-name 365 (propertize name 366 'font-lock-face 367 (lsp-headerline--face-for-symbol symbol))) 368 (symbol2-icon (lsp-headerline--symbol-icon symbol)) 369 (full-symbol-2 370 (concat 371 (if lsp-headerline-breadcrumb-enable-symbol-numbers 372 (concat 373 (propertize (number-to-string index) 374 'face 375 'lsp-headerline-breadcrumb-symbols-face) 376 " ") 377 "") 378 (if symbol2-icon 379 (concat symbol2-icon symbol2-name) 380 symbol2-name)))) 381 (lsp-headerline--symbol-with-action symbol full-symbol-2))) 382 enumerated-symbols-hierarchy 383 (concat " " (lsp-headerline--arrow-icon) " ")) 384 "") 385 "")) 386 387 (defun lsp-headerline--build-string () 388 "Build the header-line string." 389 (string-trim-right 390 (mapconcat 391 (lambda (segment) 392 (let ((segment-string 393 (pcase segment 394 ('project (lsp-headerline--build-project-string)) 395 ('file (lsp-headerline--build-file-string)) 396 ('path-up-to-project (lsp-headerline--build-path-up-to-project-string)) 397 ('symbols (lsp-headerline--build-symbol-string)) 398 (_ (lsp-log "'%s' is not a valid entry for `lsp-headerline-breadcrumb-segments'" 399 (symbol-name segment)) 400 "")))) 401 (if (string-empty-p segment-string) 402 "" 403 (concat (lsp-headerline--arrow-icon) 404 " " 405 segment-string 406 " ")))) 407 lsp-headerline-breadcrumb-segments 408 ""))) 409 410 (defun lsp-headerline--check-breadcrumb (&rest _) 411 "Request for document symbols to build the breadcrumb." 412 (set-window-parameter (selected-window) 'lsp-headerline--string (lsp-headerline--build-string)) 413 (force-mode-line-update)) 414 415 (defun lsp-headerline--enable-breadcrumb () 416 "Enable headerline breadcrumb mode." 417 (when (and lsp-headerline-breadcrumb-enable 418 (lsp-feature? "textDocument/documentSymbol")) 419 (lsp-headerline-breadcrumb-mode 1))) 420 421 (defun lsp-headerline--disable-breadcrumb () 422 "Disable headerline breadcrumb mode." 423 (lsp-headerline-breadcrumb-mode -1)) 424 425 (defun lsp-headerline--workspace-root () 426 (or lsp-headerline--cached-workspace-root 427 (setq lsp-headerline--cached-workspace-root (lsp-workspace-root)))) 428 429 ;;;###autoload 430 (define-minor-mode lsp-headerline-breadcrumb-mode 431 "Toggle breadcrumb on headerline." 432 :group 'lsp-headerline 433 :global nil 434 (cond 435 (lsp-headerline-breadcrumb-mode 436 ;; make sure header-line-format, if non-nil, is a list. as 437 ;; mode-line-format says: "The value may be nil, a string, a 438 ;; symbol or a list." 439 (unless (listp header-line-format) 440 (setq header-line-format (list header-line-format))) 441 (add-to-list 'header-line-format '(t (:eval (window-parameter nil 'lsp-headerline--string) ))) 442 443 (add-hook 'xref-after-jump-hook #'lsp-headerline--check-breadcrumb nil t) 444 445 (add-hook 'lsp-on-idle-hook #'lsp-headerline--check-breadcrumb nil t) 446 (add-hook 'lsp-configure-hook #'lsp-headerline--enable-breadcrumb nil t) 447 (add-hook 'lsp-unconfigure-hook #'lsp-headerline--disable-breadcrumb nil t)) 448 (t 449 (remove-hook 'lsp-on-idle-hook #'lsp-headerline--check-breadcrumb t) 450 (remove-hook 'lsp-configure-hook #'lsp-headerline--enable-breadcrumb t) 451 (remove-hook 'lsp-unconfigure-hook #'lsp-headerline--disable-breadcrumb t) 452 453 (remove-hook 'xref-after-jump-hook #'lsp-headerline--check-breadcrumb t) 454 455 (setq lsp-headerline--path-up-to-project-segments nil) 456 (setq header-line-format (remove '(t (:eval (window-parameter nil 'lsp-headerline--string) )) header-line-format))))) 457 458 ;;;###autoload 459 (defun lsp-breadcrumb-go-to-symbol (symbol-position) 460 "Go to the symbol on breadcrumb at SYMBOL-POSITION." 461 (interactive "P") 462 (if (numberp symbol-position) 463 (if (lsp-feature? "textDocument/documentSymbol") 464 (-if-let* ((lsp--document-symbols-request-async t) 465 (symbols (lsp--get-document-symbols)) 466 (symbols-hierarchy (lsp--symbols->document-symbols-hierarchy symbols))) 467 (lsp-headerline--go-to-symbol (nth (1- symbol-position) symbols-hierarchy)) 468 (lsp--info "Symbol not found for position %s" symbol-position)) 469 (lsp--info "Server does not support breadcrumb.")) 470 (lsp--info "Call this function with a number representing the symbol position on breadcrumb"))) 471 472 (declare-function evil-set-command-property "ext:evil-common") 473 474 (with-eval-after-load 'evil 475 (evil-set-command-property 'lsp-breadcrumb-go-to-symbol :jump t)) 476 477 ;;;###autoload 478 (defun lsp-breadcrumb-narrow-to-symbol (symbol-position) 479 "Narrow to the symbol range on breadcrumb at SYMBOL-POSITION." 480 (interactive "P") 481 (if (numberp symbol-position) 482 (if (lsp-feature? "textDocument/documentSymbol") 483 (-if-let* ((lsp--document-symbols-request-async t) 484 (symbols (lsp--get-document-symbols)) 485 (symbols-hierarchy (lsp--symbols->document-symbols-hierarchy symbols))) 486 (lsp-headerline--narrow-to-symbol (nth (1- symbol-position) symbols-hierarchy)) 487 (lsp--info "Symbol not found for position %s" symbol-position)) 488 (lsp--info "Server does not support breadcrumb.")) 489 (lsp--info "Call this function with a number representing the symbol position on breadcrumb"))) 490 491 (lsp-consistency-check lsp-headerline) 492 493 (provide 'lsp-headerline) 494 ;;; lsp-headerline.el ends here