lsp-headerline.el (21939B)
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-material-icon 161 "chevron_right" 162 'lsp-headerline-breadcrumb-separator-face 163 ">" 164 'headerline-breadcrumb))))) 165 166 (lsp-defun lsp-headerline--symbol-icon ((&DocumentSymbol :kind)) 167 "Build the SYMBOL icon for headerline breadcrumb." 168 (concat (lsp-icons-get-by-symbol-kind kind 'headerline-breadcrumb) 169 " ")) 170 171 (lsp-defun lsp-headerline--go-to-symbol ((&DocumentSymbol 172 :selection-range (&RangeToPoint :start selection-start) 173 :range (&RangeToPoint :start narrowing-start 174 :end narrowing-end))) 175 "Go to breadcrumb symbol. 176 If the buffer is narrowed and the target symbol lies before the 177 minimum reachable point in the narrowed buffer, then widen and 178 narrow to the outer symbol." 179 (when (buffer-narrowed-p) 180 (narrow-to-region 181 (min (point-min) narrowing-start) 182 (max (point-max) narrowing-end))) 183 (goto-char selection-start)) 184 185 (lsp-defun lsp-headerline--narrow-to-symbol ((&DocumentSymbol :range (&RangeToPoint :start :end))) 186 "Narrow to breadcrumb symbol range." 187 (narrow-to-region start end)) 188 189 (defun lsp-headerline--with-action (local-map help-echo-string display-string) 190 "Assign LOCAL-MAP and HELP-ECHO-STRING to the region around the 191 DISPLAY-STRING." 192 (propertize display-string 193 'mouse-face 'header-line-highlight 194 'help-echo help-echo-string 195 'local-map local-map)) 196 197 (defmacro lsp-headerline--make-mouse-handler (&rest body) 198 "Making mouse event handler. 199 Switch to current mouse interacting window before doing BODY." 200 (declare (debug t) (indent 0)) 201 `(lambda (event) 202 (interactive "e") 203 (select-window (posn-window (elt event 1))) 204 ,@body)) 205 206 (defun lsp-headerline--directory-with-action (full-path directory-display-string) 207 "Build action for FULL-PATH and DIRECTORY-DISPLAY-STRING." 208 (lsp-headerline--with-action (let ((map (make-sparse-keymap))) 209 (define-key map [header-line mouse-1] 210 (lsp-headerline--make-mouse-handler 211 (dired full-path))) 212 (define-key map [header-line mouse-2] 213 (lsp-headerline--make-mouse-handler 214 (dired-other-window full-path))) 215 map) 216 (format "mouse-1: browse '%s' with Dired\nmouse-2: browse '%s' with Dired in other window" 217 directory-display-string 218 directory-display-string) 219 (propertize directory-display-string 220 'lsp-full-path full-path))) 221 222 (declare-function evil-set-jump "ext:evil-jumps") 223 224 (lsp-defun lsp-headerline--symbol-with-action ((symbol &as &DocumentSymbol :name) symbol-display-string) 225 "Build action for SYMBOL and SYMBOL-STRING." 226 (lsp-headerline--with-action (let ((map (make-sparse-keymap))) 227 (define-key map [header-line mouse-1] 228 (lsp-headerline--make-mouse-handler 229 (when (bound-and-true-p evil-mode) 230 (evil-set-jump)) 231 (lsp-headerline--go-to-symbol symbol))) 232 (define-key map [header-line mouse-2] 233 (lsp-headerline--make-mouse-handler 234 (-let (((&DocumentSymbol :range (&RangeToPoint :start :end)) symbol)) 235 (if (and (eq (point-min) start) (eq (point-max) end)) 236 (widen) 237 (lsp-headerline--narrow-to-symbol symbol))))) 238 map) 239 (format "mouse-1: go to '%s' symbol\nmouse-2: %s" 240 name 241 (-let (((&DocumentSymbol :range (&RangeToPoint :start :end)) symbol)) 242 (if (and (eq (point-min) start) (eq (point-max) end)) 243 "widen" 244 (format "narrow to '%s' range" name)))) 245 symbol-display-string)) 246 247 (defun lsp-headerline--path-up-to-project-root (root-path path) 248 "Find recursively the folders until the project ROOT-PATH. 249 PATH is the current folder to be checked." 250 (let ((current-path path) 251 headerline-path-components) 252 (while (not (lsp-f-same? root-path current-path)) 253 (push (lsp-headerline--directory-with-action current-path 254 (f-filename current-path)) 255 headerline-path-components) 256 (setq current-path (lsp-f-parent current-path))) 257 headerline-path-components)) 258 259 (defun lsp-headerline--build-project-string () 260 "Build the project-segment string for the breadcrumb." 261 (-if-let (root (lsp-headerline--workspace-root)) 262 (propertize (lsp-headerline--directory-with-action 263 root 264 (f-filename root)) 265 'font-lock-face 266 'lsp-headerline-breadcrumb-project-prefix-face) 267 (propertize "<unknown>" 268 'font-lock-face 269 'lsp-headerline-breadcrumb-unknown-project-prefix-face))) 270 271 (defun lsp-headerline--build-file-string () 272 "Build the file-segment string for the breadcrumb." 273 (let* ((file-path (or (buffer-file-name) "")) 274 (filename (f-filename file-path))) 275 (if-let ((file-ext (f-ext file-path))) 276 (concat (lsp-icons-get-by-file-ext file-ext 'headerline-breadcrumb) 277 " " 278 (propertize filename 279 'font-lock-face 280 (lsp-headerline--face-for-path file-path))) 281 filename))) 282 283 284 (defun lsp-headerline--face-for-path (dir) 285 "Calculate the face for DIR." 286 (if-let ((diags (lsp-diagnostics-stats-for (directory-file-name dir)))) 287 (cl-labels ((check-severity 288 (severity) 289 (not (zerop (aref diags severity))))) 290 (cond 291 ((not lsp-headerline-breadcrumb-enable-diagnostics) 292 'lsp-headerline-breadcrumb-path-face) 293 ((check-severity lsp/diagnostic-severity-error) 294 'lsp-headerline-breadcrumb-path-error-face) 295 ((check-severity lsp/diagnostic-severity-warning) 296 'lsp-headerline-breadcrumb-path-warning-face) 297 ((check-severity lsp/diagnostic-severity-information) 298 'lsp-headerline-breadcrumb-path-info-face) 299 ((check-severity lsp/diagnostic-severity-hint) 300 'lsp-headerline-breadcrumb-path-hint-face) 301 (t 'lsp-headerline-breadcrumb-path-face))) 302 'lsp-headerline-breadcrumb-path-face)) 303 304 (defun lsp-headerline--severity-level-for-range (range) 305 "Get the severity level for RANGE." 306 (let ((range-severity 10)) 307 (mapc (-lambda ((&Diagnostic :range (&Range :start) :severity?)) 308 (when (lsp-point-in-range? start range) 309 (setq range-severity (min range-severity severity?)))) 310 (lsp--get-buffer-diagnostics)) 311 range-severity)) 312 313 (defun lsp-headerline--build-path-up-to-project-string () 314 "Build the path-up-to-project segment for the breadcrumb." 315 (if-let ((root (lsp-headerline--workspace-root))) 316 (let ((segments (or 317 lsp-headerline--path-up-to-project-segments 318 (setq lsp-headerline--path-up-to-project-segments 319 (lsp-headerline--path-up-to-project-root 320 root 321 (lsp-f-parent (buffer-file-name))))))) 322 (mapconcat (lambda (next-dir) 323 (propertize next-dir 324 'font-lock-face 325 (lsp-headerline--face-for-path 326 (get-text-property 327 0 'lsp-full-path next-dir)))) 328 segments 329 (concat " " (lsp-headerline--arrow-icon) " "))) 330 "")) 331 332 (lsp-defun lsp-headerline--face-for-symbol ((&DocumentSymbol :deprecated? 333 :range)) 334 "Get the face for SYMBOL." 335 (let ((range-severity (lsp-headerline--severity-level-for-range range))) 336 (cond 337 (deprecated? 'lsp-headerline-breadcrumb-deprecated-face) 338 ((not lsp-headerline-breadcrumb-enable-diagnostics) 339 'lsp-headerline-breadcrumb-symbols-face) 340 ((= range-severity lsp/diagnostic-severity-error) 341 'lsp-headerline-breadcrumb-symbols-error-face) 342 ((= range-severity lsp/diagnostic-severity-warning) 343 'lsp-headerline-breadcrumb-symbols-warning-face) 344 ((= range-severity lsp/diagnostic-severity-information) 345 'lsp-headerline-breadcrumb-symbols-info-face) 346 ((= range-severity lsp/diagnostic-severity-hint) 347 'lsp-headerline-breadcrumb-symbols-hint-face) 348 (t 'lsp-headerline-breadcrumb-symbols-face)))) 349 350 (defun lsp-headerline--build-symbol-string () 351 "Build the symbol segment for the breadcrumb." 352 (if (lsp-feature? "textDocument/documentSymbol") 353 (-if-let* ((lsp--document-symbols-request-async t) 354 (symbols (lsp--get-document-symbols)) 355 (symbols-hierarchy (lsp--symbols->document-symbols-hierarchy symbols)) 356 (enumerated-symbols-hierarchy 357 (-map-indexed (lambda (index elt) 358 (cons elt (1+ index))) 359 symbols-hierarchy))) 360 (mapconcat 361 (-lambda (((symbol &as &DocumentSymbol :name) 362 . index)) 363 (let* ((symbol2-name 364 (propertize name 365 'font-lock-face 366 (lsp-headerline--face-for-symbol symbol))) 367 (symbol2-icon (lsp-headerline--symbol-icon symbol)) 368 (full-symbol-2 369 (concat 370 (if lsp-headerline-breadcrumb-enable-symbol-numbers 371 (concat 372 (propertize (number-to-string index) 373 'face 374 'lsp-headerline-breadcrumb-symbols-face) 375 " ") 376 "") 377 (if symbol2-icon 378 (concat symbol2-icon symbol2-name) 379 symbol2-name)))) 380 (lsp-headerline--symbol-with-action symbol full-symbol-2))) 381 enumerated-symbols-hierarchy 382 (concat " " (lsp-headerline--arrow-icon) " ")) 383 "") 384 "")) 385 386 (defun lsp-headerline--build-string () 387 "Build the header-line string." 388 (string-trim-right 389 (mapconcat 390 (lambda (segment) 391 (let ((segment-string 392 (pcase segment 393 ('project (lsp-headerline--build-project-string)) 394 ('file (lsp-headerline--build-file-string)) 395 ('path-up-to-project (lsp-headerline--build-path-up-to-project-string)) 396 ('symbols (lsp-headerline--build-symbol-string)) 397 (_ (lsp-log "'%s' is not a valid entry for `lsp-headerline-breadcrumb-segments'" 398 (symbol-name segment)) 399 "")))) 400 (if (string-empty-p segment-string) 401 "" 402 (concat (lsp-headerline--arrow-icon) 403 " " 404 segment-string 405 " ")))) 406 lsp-headerline-breadcrumb-segments 407 ""))) 408 409 (defun lsp-headerline--check-breadcrumb (&rest _) 410 "Request for document symbols to build the breadcrumb." 411 (set-window-parameter (selected-window) 'lsp-headerline--string (lsp-headerline--build-string)) 412 (force-mode-line-update)) 413 414 (defun lsp-headerline--enable-breadcrumb () 415 "Enable headerline breadcrumb mode." 416 (when (and lsp-headerline-breadcrumb-enable 417 (lsp-feature? "textDocument/documentSymbol")) 418 (lsp-headerline-breadcrumb-mode 1))) 419 420 (defun lsp-headerline--disable-breadcrumb () 421 "Disable headerline breadcrumb mode." 422 (lsp-headerline-breadcrumb-mode -1)) 423 424 (defun lsp-headerline--workspace-root () 425 (or lsp-headerline--cached-workspace-root 426 (setq lsp-headerline--cached-workspace-root (lsp-workspace-root)))) 427 428 ;;;###autoload 429 (define-minor-mode lsp-headerline-breadcrumb-mode 430 "Toggle breadcrumb on headerline." 431 :group 'lsp-headerline 432 :global nil 433 (cond 434 (lsp-headerline-breadcrumb-mode 435 ;; make sure header-line-format, if non-nil, is a list. as 436 ;; mode-line-format says: "The value may be nil, a string, a 437 ;; symbol or a list." 438 (unless (listp header-line-format) 439 (setq header-line-format (list header-line-format))) 440 (add-to-list 'header-line-format '(t (:eval (window-parameter nil 'lsp-headerline--string) ))) 441 442 (add-hook 'xref-after-jump-hook #'lsp-headerline--check-breadcrumb nil t) 443 444 (add-hook 'lsp-on-idle-hook #'lsp-headerline--check-breadcrumb nil t) 445 (add-hook 'lsp-configure-hook #'lsp-headerline--enable-breadcrumb nil t) 446 (add-hook 'lsp-unconfigure-hook #'lsp-headerline--disable-breadcrumb nil t)) 447 (t 448 (remove-hook 'lsp-on-idle-hook #'lsp-headerline--check-breadcrumb t) 449 (remove-hook 'lsp-configure-hook #'lsp-headerline--enable-breadcrumb t) 450 (remove-hook 'lsp-unconfigure-hook #'lsp-headerline--disable-breadcrumb t) 451 452 (remove-hook 'xref-after-jump-hook #'lsp-headerline--check-breadcrumb t) 453 454 (setq lsp-headerline--path-up-to-project-segments nil) 455 (setq header-line-format (remove '(t (:eval (window-parameter nil 'lsp-headerline--string) )) header-line-format))))) 456 457 ;;;###autoload 458 (defun lsp-breadcrumb-go-to-symbol (symbol-position) 459 "Go to the symbol on breadcrumb at SYMBOL-POSITION." 460 (interactive "P") 461 (if (numberp symbol-position) 462 (if (lsp-feature? "textDocument/documentSymbol") 463 (-if-let* ((lsp--document-symbols-request-async t) 464 (symbols (lsp--get-document-symbols)) 465 (symbols-hierarchy (lsp--symbols->document-symbols-hierarchy symbols))) 466 (lsp-headerline--go-to-symbol (nth (1- symbol-position) symbols-hierarchy)) 467 (lsp--info "Symbol not found for position %s" symbol-position)) 468 (lsp--info "Server does not support breadcrumb.")) 469 (lsp--info "Call this function with a number representing the symbol position on breadcrumb"))) 470 471 (declare-function evil-set-command-property "ext:evil-common") 472 473 (with-eval-after-load 'evil 474 (evil-set-command-property 'lsp-breadcrumb-go-to-symbol :jump t)) 475 476 ;;;###autoload 477 (defun lsp-breadcrumb-narrow-to-symbol (symbol-position) 478 "Narrow to the symbol range on breadcrumb at SYMBOL-POSITION." 479 (interactive "P") 480 (if (numberp symbol-position) 481 (if (lsp-feature? "textDocument/documentSymbol") 482 (-if-let* ((lsp--document-symbols-request-async t) 483 (symbols (lsp--get-document-symbols)) 484 (symbols-hierarchy (lsp--symbols->document-symbols-hierarchy symbols))) 485 (lsp-headerline--narrow-to-symbol (nth (1- symbol-position) symbols-hierarchy)) 486 (lsp--info "Symbol not found for position %s" symbol-position)) 487 (lsp--info "Server does not support breadcrumb.")) 488 (lsp--info "Call this function with a number representing the symbol position on breadcrumb"))) 489 490 (lsp-consistency-check lsp-headerline) 491 492 (provide 'lsp-headerline) 493 ;;; lsp-headerline.el ends here