fedora-csb-system-manager
1;;; project-headerline.el --- Customizable project headerline -*- lexical-binding: t -*-
2
3;; Copyright (C) 2025 Victor Gaydov and contributors
4;; Copyright (C) 2020 emacs-lsp maintainers
5
6;; Author: Victor Gaydov <victor@enise.org>
7;; Created: 03 Feb 2025
8;; URL: https://github.com/gavv/project-headerline
9;; Version: 0.4
10;; Package-Requires: ((emacs "28.2") (f "0.21.0") (s "1.13.0") (all-the-icons "5.0.0"))
11;; Keywords: convenience
12
13;;; License:
14
15;; This program is free software; you can redistribute it and/or modify
16;; it under the terms of the GNU General Public License as published by
17;; the Free Software Foundation, either version 3 of the License, or
18;; (at your option) any later version.
19
20;; This program is distributed in the hope that it will be useful,
21;; but WITHOUT ANY WARRANTY; without even the implied warranty of
22;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23;; GNU General Public License for more details.
24
25;; You should have received a copy of the GNU General Public License
26;; along with this program. If not, see <https://www.gnu.org/licenses/>.
27
28;;; Notice:
29
30;; Several functions were ported from lsp-headerline.el, so the copyrights
31;; includes one from that module.
32
33;;; Commentary:
34
35;; project-headerline implements a minor mode that shows a headerline with
36;; current project name, and the path to current buffer from the project root.
37
38;; It is inspired by lsp-headerline, but it doesn't show symbol and diagnostic
39;; information, has no dependency on lsp, and can be used for buffers of any kind.
40
41;; Please refer to README.org and docstrings for further details.
42
43;;; Code:
44
45(require 'dired-aux)
46(require 'project)
47(require 'seq)
48(require 'vc)
49
50(require 'projectile nil 'noerror)
51(require 'magit nil 'noerror)
52(require 'all-the-icons nil 'noerror)
53
54(require 'f)
55(require 's)
56
57(defgroup project-headerline nil
58 "Customizable project headerline."
59 :prefix "project-headerline-"
60 :group 'convenience
61 :link '(url-link "https://github.com/gavv/project-headerline"))
62
63(defface project-headerline-project-name
64 '((t :inherit font-lock-string-face :weight bold))
65 "Face used for \\='project-name segment."
66 :package-version '(project-headerline . "0.1")
67 :group 'project-headerline)
68
69(defface project-headerline-path-in-project
70 '((t :inherit font-lock-keyword-face))
71 "Face used for \\='path-in-project segment."
72 :package-version '(project-headerline . "0.1")
73 :group 'project-headerline)
74
75(defface project-headerline-buffer-name
76 '((t :inherit font-lock-builtin-face))
77 "Face used for \\='buffer-name segment."
78 :package-version '(project-headerline . "0.1")
79 :group 'project-headerline)
80
81(defface project-headerline-segment-separator
82 '((t :inherit shadow :height 0.8))
83 "Face used for separator between segments."
84 :package-version '(project-headerline . "0.1")
85 :group 'project-headerline)
86
87(defface project-headerline-path-separator
88 '((t :inherit shadow :height 0.8))
89 "Face used for between path components inside `path-in-project' segment."
90 :package-version '(project-headerline . "0.1")
91 :group 'project-headerline)
92
93(defface project-headerline-space
94 '((t :height 0.5))
95 "Face used for spaces around segment and path separators."
96 :package-version '(project-headerline . "0.2")
97 :group 'project-headerline)
98
99(defcustom project-headerline-display-segments
100 '(
101 ;; list of pre-defined symbols, each symbol corresponds to a segment
102 project-name
103 path-in-project
104 buffer-name
105 ;;
106 )
107 "Which segments to show and in what order.
108
109Must be a list of symbols, where each symbol represents a segment:
110
111 - `project-name' - name of project where current file belongs
112 - `path-in-project' - relative path from project root up to the current file
113 - `buffer-name' - file name or buffer name
114
115`path-in-project' segment is present only if buffer is file or directory.
116`buffer-name' segment displays file or directory name if buffer is visiting one,
117and uses function (buffer-name) otherwise."
118 :package-version '(project-headerline . "0.1")
119 :group 'project-headerline
120 :type '(repeat
121 (choice (const :tag "Project name." project-name)
122 (const :tag "Directories up to project." path-in-project)
123 (const :tag "Buffer or file name." buffer-name)))
124 :initialize 'custom-initialize-default
125 :set 'project-headerline--set-variable)
126
127(defcustom project-headerline-segment-separator nil
128 "String or icon to separate segments.
129
130Icon is actually also a string, but with special properties.
131For example, you can create one using `all-the-icons-material'.
132
133When separator is nil, `project-headerline-icon-function' is used
134to create it with default icon name."
135 :package-version '(project-headerline . "0.1")
136 :group 'project-headerline
137 :type '(choice (const :tag "Default" nil)
138 string)
139 :initialize 'custom-initialize-default
140 :set 'project-headerline--set-variable)
141
142(defcustom project-headerline-path-separator nil
143 "String or icon to separate path components inside \\='path-in-project segment.
144
145Icon is actually also a string, but with special properties.
146For example, you can create one using `all-the-icons-material'.
147
148When separator is nil, `project-headerline-icon-function' is used
149to create it with default icon name."
150 :package-version '(project-headerline . "0.1")
151 :group 'project-headerline
152 :type '(choice (const :tag "Default" nil)
153 string)
154 :initialize 'custom-initialize-default
155 :set 'project-headerline--set-variable)
156
157(defcustom project-headerline-path-ellipsis "..."
158 "String or icon used when \\='path-in-project' segment is truncated.
159
160If the segment is too long, a few leading path components are
161replaced with the value of this variable."
162 :package-version '(project-headerline . "0.1")
163 :group 'project-headerline
164 :type 'string
165 :initialize 'custom-initialize-default
166 :set 'project-headerline--set-variable)
167
168(defcustom project-headerline-detect-alist
169 `(
170 ;; detect using projectile, if installed
171 (projectile :allow-remote nil
172 :describe ,(lambda ()
173 (when (and (featurep 'projectile)
174 (projectile-project-p))
175 (list :name (projectile-project-name)
176 :path (projectile-project-root)))))
177 ;; detect using builtin project.el package
178 (project :allow-remote nil
179 :describe ,(lambda ()
180 (when-let* ((project (project-current)))
181 (list :name (f-base (project-root project))
182 :path (project-root project)))))
183 ;; detect using magit, if installed
184 (magit :allow-remote nil
185 :describe ,(lambda ()
186 (when (featurep 'magit)
187 (when-let* ((magit-root (magit-toplevel)))
188 (list :name (f-filename magit-root)
189 :path (f-full magit-root))))))
190 ;; detect using builtin vc package
191 (vc :allow-remote nil
192 :describe ,(lambda ()
193 (when-let* ((vc-root (vc-root-dir)))
194 (list :name (f-filename vc-root)
195 :path (f-full vc-root)))))
196 ;;
197 )
198 "Assoc list of project detection methods.
199
200Assoc list key is a symbol of your choice.
201Assoc list value is a plist with the following properties:
202 - `:allow-remote' - whether to use this method on remote files
203 - `:describe' - detection function
204
205`:allow-remote' is by default disabled for all methods because it
206may be very slow (depending on your connection).
207
208Detection function should take no arguments and return a plist:
209 - `:name' - project name
210 - `:path' - project path (tramp paths are allowed)
211
212Detection methods are tried one by one, until some of them
213returns non-nil.
214
215Used by default implementation of
216`project-headerline-describe-project-function'."
217 :package-version '(project-headerline . "0.1")
218 :group 'project-headerline
219 :type '(alist :key-type symbol
220 :value-type (plist :options ((:allow-remote boolean)
221 (:describe function))))
222 :initialize 'custom-initialize-default
223 :set 'project-headerline--set-variable)
224
225(defcustom project-headerline-fallback-alist
226 '(
227 ;; pseudo-project "~" for all orphan files under $HOME
228 ("~" . "~/")
229 ;; pseudo-project "/" for all other orphan files
230 ("/" . "/")
231 ;;
232 )
233 "Assoc list of fallback projects when normal detection fails.
234
235Assoc list key is project name.
236Assoc list value is project path.
237
238If no project was detected using `project-headerline-detect-alist',
239then `project-headerline-fallback-alist' is scanned. A fallback
240project is selected if it's path is the parent of buffer's path.
241
242You can use it both for real projects with hard-coded paths
243\(e.g. if they're not identified by common methods), and for
244fallbacks for buffers that don't really belong to a project.
245
246By default, two `pseudo projects` are registered: `~' for any
247file inside home directory, and `/' for any file elsewhere
248on filesystem. You can disable this by removing corresponding
249elements from the assoc list."
250 :package-version '(project-headerline . "0.1")
251 :group 'project-headerline
252 :type '(alist :key-type (string :tag "Project Name")
253 :value-type (string :tag "Project Path"))
254 :initialize 'custom-initialize-default
255 :set 'project-headerline--set-variable)
256
257(defcustom project-headerline-rename-alist
258 '(
259 ;; magit
260 ("^\\(magit\\):.*" . "\\1")
261 ("^\\(magit-[a-z]+\\):.*" . "\\1")
262 ;; compilation
263 ("^\\*compilation\\*<.*>" . "compilation")
264 ("^\\*compilation<.*>\\*" . "compilation")
265 ;;
266 )
267 "Assoc list of buffer rename rules.
268
269Assoc list key is a regular expression.
270Assoc list value is a replacement string that can use capture groups.
271
272Keys and values are passed to `replace-regexp-in-string' and FROM and
273TO arguments. If any of the rule matches buffer, buffer name displayed
274in headerline is changed according to the replacement."
275 :package-version '(project-headerline . "0.1")
276 :group 'project-headerline
277 :type '(alist :key-type (string :tag "Buffer Name Regexp")
278 :value-type (string :tag "Buffer Name Replacement"))
279 :initialize 'custom-initialize-default
280 :set 'project-headerline--set-variable)
281
282(defcustom project-headerline-describe-project-function
283 #'project-headerline-describe-project
284 "Function that returns properties of current project.
285
286Takes no arguments and returns plist:
287 - `:name' - project name
288 - `:path' - project directory path
289
290Default implementation uses the following algorithm:
291 - if `project-headerline-current-project' is set, uses it
292 - tries rules from `project-headerline-detect-alist'
293 - tries paths from `project-headerline-fallback-alist'"
294 :package-version '(project-headerline . "0.1")
295 :group 'project-headerline
296 :type 'function
297 :initialize 'custom-initialize-default
298 :set 'project-headerline--set-variable)
299
300(defcustom project-headerline-describe-buffer-function
301 #'project-headerline-describe-buffer
302 "Function that returns properties of current buffer.
303
304Takes no arguments and returns plist:
305 - `:type' - kind of buffer, one of the symbols: `file', `dir', `other'
306 - `:dir' - path to buffer's directory
307 - `:name' - name of buffer
308
309For `file' buffers, `:dir' is path to directory containing the file.
310For `dir' buffers, `:dir' is path to directory itself.
311For `other' buffers, `:dir' is path to a directory associated with
312the buffer, typically `default-directory' inside that buffer.
313
314Default implementation reports `dir' for Dired buffers, `file' for
315buffers with non-empty variable `buffer-file-name', and `other' for
316the rest. It also applies buffer renaming rules according to variable
317`project-headerline-rename-alist'."
318 :package-version '(project-headerline . "0.1")
319 :group 'project-headerline
320 :type 'function
321 :initialize 'custom-initialize-default
322 :set 'project-headerline--set-variable)
323
324(defcustom project-headerline-format-function
325 #'project-headerline-format
326 "Function to format headerline from project and buffer properties.
327
328Takes two arguments:
329 - `project' - plist from `project-headerline-describe-project-function'
330 - `buffer' - plist from `project-headerline-describe-buffer-function'
331
332Returns propertized string with headerline contents.
333
334Default implementation formats headerline according to variables
335`project-headerline-display-segments', `project-headerline-segment-separator',
336`project-headerline-path-separator' (or `project-headerline-icon-function'),
337and applies corresponding faces."
338 :package-version '(project-headerline . "0.1")
339 :group 'project-headerline
340 :type 'function
341 :initialize 'custom-initialize-default
342 :set 'project-headerline--set-variable)
343
344(defcustom project-headerline-icon-function
345 #'project-headerline-icon
346 "Function to create icon from name.
347
348Takes two arguments:
349 - `icon-name' - string name of the icon
350 - `icon-face' - face to apply to the icon
351
352Returns propertized string with the icon.
353If icon is not available, returns nil. In this case fallback
354character will be used instead of the icon.
355
356Default implementation uses `all-the-icons-material' when it's
357available, or returns nil otherwise."
358 :package-version '(project-headerline . "0.1")
359 :group 'project-headerline
360 :type 'function
361 :initialize 'custom-initialize-default
362 :set 'project-headerline--set-variable)
363
364(defcustom project-headerline-width-function
365 #'project-headerline-width
366 "Function to return maximum headerline width.
367Takes no arguments and returns number of characters."
368 :package-version '(project-headerline . "0.1")
369 :group 'project-headerline
370 :type 'function
371 :initialize 'custom-initialize-default
372 :set 'project-headerline--set-variable)
373
374(defcustom project-headerline-mode-list
375 '(prog-mode
376 conf-mode
377 text-mode
378 dired-mode)
379 "Modes in which to enable `project-headerline-mode' automatically.
380
381When `global-project-headerline-mode' is enabled, it enables headerline
382in buffer if its major mode is derived from one of these modes.
383
384Note that minibuffer and hidden buffers are always excluded."
385 :package-version '(project-headerline . "0.1")
386 :group 'project-headerline
387 :type '(repeat symbol))
388
389(defvar-local project-headerline-current-project nil
390 "Overwrite current project path.
391
392If this variable is set, it is used instead of `project-headerline-detect-alist'
393and `project-headerline-fallback-alist' and defines project name and path.
394
395It can be either a string or a list:
396
397 - If it's a string, it should be a path to project directory. Project name
398 is set to the directory name.
399
400 - If it's a list, it should be a plist with project properties, in the same
401 format as returned by `project-headerline-describe-project-function'.
402
403It's convenient to set this from local variables, e.g. in `.dir-locals.el'
404in the project root.")
405
406;; Forward-declate mode variable.
407(defvar project-headerline-mode)
408
409(defun project-headerline--set-variable (symbol value)
410 "Setter for defcustom.
411Assigns value to variable and invokes `project-headerline-reset'."
412 (set-default-toplevel-value symbol value)
413 (project-headerline-reset))
414
415(defvar-local project-headerline--cache nil)
416
417(defmacro project-headerline--cached (key form)
418 "Cached evaluation of form.
419If there is cached value for KEY, return it.
420Otherwise, evaluate FORM, store in cache, and return it."
421 `(let ((cache project-headerline--cache))
422 (unless cache
423 (setq cache (make-hash-table :test 'eq))
424 (setq-local project-headerline--cache cache))
425 (or (gethash ,key cache)
426 (puthash ,key ,form cache))))
427
428(defmacro project-headerline--call (func-or-cons &rest args)
429 "Call user function.
430On error, display warning and return nil."
431 (let ((func (if (consp func-or-cons)
432 (car func-or-cons)
433 func-or-cons))
434 (name (if (consp func-or-cons)
435 (cdr func-or-cons)
436 (symbol-name func-or-cons))))
437 `(condition-case err
438 (funcall ,func ,@args)
439 (error
440 (warn "Caught error from %s: %s" ,name
441 (error-message-string err))
442 nil))))
443
444(defun project-headerline-describe-project ()
445 "Get current project properties.
446Default implementation of `project-headerline-describe-project-function',
447see its docstring for details."
448 (or (project-headerline--project-from-variable)
449 (project-headerline--project-from-detect-alist)
450 (project-headerline--project-from-fallback-alist)))
451
452(defun project-headerline--project-from-variable ()
453 "Get project from `project-headerline-current-project'."
454 (when project-headerline-current-project
455 (cond ((stringp project-headerline-current-project)
456 (list :name (f-filename project-headerline-current-project)
457 :path (f-full project-headerline-current-project)))
458 ((plistp project-headerline-current-project)
459 project-headerline-current-project)
460 (t
461 (warn "Invalid project-headerline-current-project")
462 nil))))
463
464(defun project-headerline--project-from-detect-alist ()
465 "Get project from `project-headerline-detect-alist'."
466 (seq-some (lambda (method)
467 (let ((allow-remote (plist-get (cdr method) :allow-remote))
468 (describe-fn (plist-get (cdr method) :describe)))
469 (when (and (or allow-remote
470 (not (file-remote-p default-directory)))
471 describe-fn)
472 (project-headerline--call
473 (describe-fn . "project-headerline-detect-alist :describe")))))
474 project-headerline-detect-alist))
475
476(defun project-headerline--project-from-fallback-alist ()
477 "Get project from `project-headerline-fallback-alist'."
478 (let* ((directory (project-headerline--buffer-dir))
479 (server (file-remote-p directory)))
480 (when directory
481 (seq-some (lambda (proj)
482 (let ((proj-name (car proj))
483 (proj-path (cdr proj)))
484 (if server
485 (when (s-prefix-p (expand-file-name (s-concat server proj-path))
486 (expand-file-name directory))
487 (list :name (s-concat server proj-name)
488 :path (expand-file-name (s-concat server proj-path))))
489 (when (s-prefix-p (f-full proj-path)
490 (f-full directory))
491 (list :name proj-name
492 :path (f-full proj-path))))))
493 project-headerline-fallback-alist))))
494
495(defun project-headerline-describe-buffer ()
496 "Get current buffer properties.
497Default implementation of `project-headerline-describe-buffer-function',
498see its docstring for details."
499 (let ((type (project-headerline--buffer-type))
500 (dir (project-headerline--buffer-dir))
501 (name (project-headerline--buffer-name)))
502 (setq name
503 (or (seq-some (lambda (rule)
504 (let ((from (car rule))
505 (to (cdr rule)))
506 (when (string-match from name)
507 (replace-regexp-in-string from to name))))
508 project-headerline-rename-alist)
509 name))
510 (list :type type
511 :dir dir
512 :name name)))
513
514(defun project-headerline--buffer-type ()
515 "Detect current buffer's type."
516 (cond
517 ;; dired
518 ((derived-mode-p 'dired-mode)
519 'dir)
520 ;; special
521 ((derived-mode-p 'special-mode)
522 'other)
523 ;; file
524 (buffer-file-name
525 'file)
526 ;; very special
527 (t
528 'other)))
529
530(defun project-headerline--buffer-dir ()
531 "Detect current buffer's directory.
532Returns path with trailing slash or nil."
533 (cond
534 ;; dired
535 ((and (derived-mode-p 'dired-mode)
536 (bound-and-true-p dired-subdir-alist))
537 (f-full (dired-current-directory)))
538 ;; file
539 (buffer-file-name
540 (f-slash (f-parent (f-full buffer-file-name))))
541 ;; cwd
542 (default-directory
543 (f-full default-directory))))
544
545(defun project-headerline--buffer-name ()
546 "Detect current buffer's name.
547For files and directories, returns base name.
548Otherwise returns buffer name."
549 (cond
550 ;; dired
551 ((and (derived-mode-p 'dired-mode)
552 (bound-and-true-p dired-subdir-alist))
553 (f-filename (dired-current-directory)))
554 ;; file
555 (buffer-file-name
556 (f-filename buffer-file-name))
557 ;; other
558 (t
559 (buffer-name))))
560
561;; Forward-declare to ensure they are not byte-compiled as lexical.
562(defvar all-the-icons-scale-factor)
563(defvar all-the-icons-default-adjust)
564
565(defun project-headerline-icon (icon-name icon-face)
566 "Format propertized icon string from icon name and face.
567Default implementation of `project-headerline-icon-function',
568see its docstring for details."
569 (when (functionp 'all-the-icons-material)
570 (let ((all-the-icons-scale-factor 1.0)
571 (all-the-icons-default-adjust -0.15))
572 (when-let* ((icon (all-the-icons-material icon-name :face icon-face))
573 (space (propertize " " 'font-lock-face 'project-headerline-space)))
574 (s-concat
575 space icon space)))))
576
577(defun project-headerline-width ()
578 "Return maximum number of characters in headerline.
579Default implementation of `project-headerline-width-function',
580see its docstring for details."
581 (window-width))
582
583(defun project-headerline--separator (key default-icon default-char)
584 "Make propertized icon string."
585 (project-headerline--cached
586 key
587 (let ((var-name (intern (format "project-headerline-%s-separator" key)))
588 (face-name (intern (format "project-headerline-%s-separator" key))))
589 (or
590 ;; user variable
591 (symbol-value var-name)
592 ;; default icon
593 (project-headerline--call project-headerline-icon-function
594 default-icon face-name)
595 ;; default char
596 (let ((char (propertize default-char 'font-lock-face face-name))
597 (space (propertize " " 'font-lock-face 'project-headerline-space)))
598 (s-concat space char space))))))
599
600(defun project-headerline--path-components (root-path path)
601 "Split path from ROOT-PATH to CURR-PATH into components."
602 (let (path-components)
603 (while (and path
604 (or (not root-path)
605 (not (f-same-p root-path path))))
606 (push (f-filename path) path-components)
607 (setq path (f-parent path)))
608 path-components))
609
610(defun project-headerline-format (project buffer)
611 "Format headerline string for project and buffer.
612Default implementation of `project-headerline-format-function',
613see its docstring for details."
614 (let* ((separator
615 (project-headerline--separator 'segment "chevron_right" ">"))
616 (margin
617 (- (or (car (window-margins)) 0)))
618 (max-width (project-headerline--call
619 project-headerline-width-function))
620 (max-path (- max-width
621 (seq-reduce
622 '+ (seq-map (lambda (segment)
623 (if (eq segment 'path-in-project)
624 0
625 (let ((str (project-headerline--format-segment
626 segment project buffer 0)))
627 (unless (s-blank-p str)
628 (+ (length separator)
629 (length str))))))
630 project-headerline-display-segments)
631 (length separator))))
632 (segments (seq-map
633 (lambda (segment)
634 (project-headerline--format-segment
635 segment project buffer max-path))
636 project-headerline-display-segments))
637 (headerline (s-join separator
638 (append '("")
639 (seq-remove 's-blank-p
640 segments)))))
641 (put-text-property 0 1 'display `(space :align-to ,margin)
642 headerline)
643 headerline))
644
645(defun project-headerline--format-segment (segment project buffer max-path)
646 "Build segment with given name."
647 (pcase segment
648 (`project-name
649 (project-headerline--format-project-name
650 project buffer))
651 (`path-in-project
652 (project-headerline--format-path-in-project
653 project buffer max-path))
654 (`buffer-name
655 (project-headerline--format-buffer-name
656 project buffer))))
657
658(defun project-headerline--format-project-name (project buffer)
659 "Build \\='project segment."
660 (ignore buffer)
661 (let ((project-name (plist-get project :name)))
662 (when (s-present-p project-name)
663 (propertize project-name
664 'font-lock-face 'project-headerline-project-name))))
665
666(defun project-headerline--format-path-in-project (project buffer max-path)
667 "Build \\='path-in-project segment."
668 (let* ((project-path (plist-get project :path))
669 (buffer-type (plist-get buffer :type))
670 (buffer-dir (plist-get buffer :dir))
671 (path-in-project (cond
672 ;; directory
673 ((eq buffer-type 'dir)
674 (if (and (seq-contains-p project-headerline-display-segments
675 'buffer-name)
676 (not (f-same-p project-path
677 buffer-dir)))
678 (f-parent buffer-dir)
679 buffer-dir))
680 ;; file or other
681 (t buffer-dir)))
682 (components (project-headerline--path-components project-path
683 path-in-project))
684 (separator
685 (project-headerline--separator 'path "chevron_right" ">")))
686 (when components
687 (let ((max-components (length components))
688 result)
689 (while (or (not result)
690 (and (> (length result) max-path 2)
691 (> max-components 0)))
692 (setq result
693 (s-join separator
694 (seq-map (lambda (seg)
695 (propertize
696 seg 'font-lock-face 'project-headerline-path-in-project))
697 (if (= max-components (length components))
698 components
699 (append (list project-headerline-path-ellipsis)
700 (seq-drop components
701 (- (length components)
702 max-components)))))))
703 (setq max-components (1- max-components)))
704 result))))
705
706(defun project-headerline--format-buffer-name (project buffer)
707 "Build \\='buffer segment."
708 (let* ((project-path (plist-get project :path))
709 (buffer-type (plist-get buffer :type))
710 (buffer-dir (plist-get buffer :dir))
711 (buffer-name (plist-get buffer :name))
712 (display-name (cond
713 ;; project root
714 ((and (eq buffer-type 'dir)
715 (f-same-p project-path buffer-dir))
716 ".")
717 ;; anything else
718 (t
719 buffer-name))))
720 (when (s-present-p display-name)
721 (propertize display-name
722 'font-lock-face 'project-headerline-buffer-name))))
723
724(defun project-headerline--compose ()
725 "Build propertized headerline string."
726 (project-headerline--cached
727 'headerline
728 (or
729 (when-let* ((project (project-headerline--call
730 project-headerline-describe-project-function))
731 (buffer (project-headerline--call
732 project-headerline-describe-buffer-function)))
733 (project-headerline--call
734 project-headerline-format-function project buffer))
735 "")))
736
737(defun project-headerline--composer-match (elem func)
738 "Match `header-line-format' element by composer function."
739 (when-let* ((form (car-safe (cdr-safe elem))))
740 (and (eq (car form) :eval)
741 (eq (caadr form) func))))
742
743(defun project-headerline--composer-append (func &rest args)
744 "Add composer function to the head of `header-line-format'."
745 (when (and header-line-format
746 (not (listp header-line-format)))
747 (setq header-line-format
748 (list header-line-format)))
749 (unless (seq-find (lambda (elem)
750 (project-headerline--composer-match elem func))
751 header-line-format)
752 (setq header-line-format
753 (append header-line-format
754 `((t (:eval (,func ,@args))))))))
755
756(defun project-headerline--composer-prepend (func &rest args)
757 "Add composer function to the tail of `header-line-format'."
758 (when (and header-line-format
759 (not (listp header-line-format)))
760 (setq header-line-format
761 (list header-line-format)))
762 (unless (seq-find (lambda (elem)
763 (project-headerline--composer-match elem func))
764 header-line-format)
765 (setq header-line-format
766 (append `((t (:eval (,func ,@args))))
767 header-line-format))))
768
769(defun project-headerline--composer-remove (func)
770 "Remove composer function from `header-line-format'."
771 (when (listp header-line-format)
772 (setq header-line-format
773 (seq-remove (lambda (elem)
774 (project-headerline--composer-match elem func))
775 header-line-format))))
776
777(defun project-headerline--magit-compose (text)
778 "Build magit headerline.
779If `project-headerline-mode' is off, produces same result as original
780`magit-set-header-line-format'. Otherwise, produces right-aligned
781headerline that can be use together with `project-headerline'."
782 (project-headerline--cached
783 'magit-headerline
784 (s-concat
785 (propertize " " 'display
786 (if project-headerline-mode
787 (let* ((margin (or (cdr (window-margins)) 0))
788 (offset (- (length text)
789 margin)))
790 `(space :align-to (- right-margin ,offset)))
791 '(space :align-to 0)))
792 text)))
793
794(defun project-headerline--magit-advice (orig-fn &rest args)
795 "Wraps magit headrline builder to support `project-headerline' in magit buffers.
796If you don't use project-headerline with magit, no visible changes are made."
797 ;; safety check: don't follow advice if signature doesn't
798 ;; match what it used to be
799 (if (and (eq 1 (length args))
800 (stringp (car args)))
801 (project-headerline--composer-append 'project-headerline--magit-compose
802 (car args))
803 (apply orig-fn args)))
804
805(defun project-headerline--rename-file-advice (orig-fn &rest args)
806 "Wraps `rename-file' to update headerline on name change."
807 (unwind-protect
808 (apply orig-fn args)
809 (let ((from (car args))
810 (to (cadr args)))
811 (project-headerline--reset-paths from to))))
812
813(defun project-headerline--add-name-to-file-advice (orig-fn &rest args)
814 "Wraps `add-name-to-file' to update headerline on name change."
815 (unwind-protect
816 (apply orig-fn args)
817 (let ((from (car args))
818 (to (cadr args)))
819 (project-headerline--reset-paths from to))))
820
821(defun project-headerline--rename-buffer-advice (orig-fn &rest args)
822 "Wraps `rename-buffer' to update headerline on name change."
823 (unwind-protect
824 (apply orig-fn args)
825 (project-headerline--reset-buffer)))
826
827(defun project-headerline--enable-maybe ()
828 "Enable `project-headerline-mode' in current buffer, if needed.
829Headerline is enabled if buffer major mode is derived from one of the modes
830in `project-headerline-mode-list'.
831Never enables in minibuffer and hidden buffers."
832 (when (and (not (minibufferp))
833 (not (string-match "^ " (buffer-name)))
834 (seq-some #'derived-mode-p project-headerline-mode-list)
835 (not project-headerline-mode))
836 (project-headerline-mode 1)))
837
838(defun project-headerline--register-advices ()
839 "Register all advices, if not registered yet."
840 (when (featurep 'magit)
841 (advice-add 'magit-set-header-line-format
842 :around #'project-headerline--magit-advice))
843 (advice-add 'rename-file
844 :around #'project-headerline--rename-file-advice)
845 (advice-add 'add-name-to-file
846 :around #'project-headerline--add-name-to-file-advice)
847 (advice-add 'rename-buffer
848 :around #'project-headerline--rename-buffer-advice))
849
850(defun project-headerline--register-hooks ()
851 "Register all hooks."
852 (add-hook 'window-configuration-change-hook
853 #'project-headerline--reset-buffer nil :local)
854 (add-hook 'after-revert-hook
855 #'project-headerline--reset-buffer nil :local)
856 (add-hook 'after-set-visited-file-name-hook
857 #'project-headerline--reset-buffer nil :local))
858
859(defun project-headerline--unregister-hooks ()
860 "Unregister all hooks."
861 (remove-hook 'window-configuration-change-hook
862 #'project-headerline--reset-buffer :local)
863 (remove-hook 'after-revert-hook
864 #'project-headerline--reset-buffer :local)
865 (remove-hook 'after-set-visited-file-name-hook
866 #'project-headerline--reset-buffer :local))
867
868(defun project-headerline--reset-buffer (&optional buffer)
869 "Refresh headerline in given BUFFER (or current)."
870 (with-current-buffer (or buffer (current-buffer))
871 (when (bound-and-true-p project-headerline--cache)
872 (setq-local project-headerline--cache nil))
873 (when project-headerline-mode
874 (force-mode-line-update))))
875
876(defun project-headerline--reset-paths (&rest paths)
877 "Refresh headerline in buffers visiting any of PATHS."
878 (dolist (buffer (buffer-list))
879 (when-let* ((buffer-path (buffer-file-name buffer)))
880 (dolist (path paths)
881 (when (and path (f-same-p buffer-path path))
882 (project-headerline--reset-buffer buffer))))))
883
884;;;###autoload
885(defun project-headerline-reset (&optional buffer)
886 "Forcibly refresh headerline in all buffers.
887If BUFFER is given, refresh only that buffer."
888 (interactive)
889 (if buffer
890 (project-headerline--reset-buffer buffer)
891 (dolist (buffer (buffer-list))
892 (project-headerline--reset-buffer buffer))))
893
894;;;###autoload
895(define-minor-mode project-headerline-mode
896 "Customizable project headerline."
897 :group 'project-headerline
898 :init-value nil
899 :lighter nil
900 (if project-headerline-mode
901 ;; enable mode
902 (progn
903 (project-headerline--composer-prepend 'project-headerline--compose)
904 (project-headerline--register-advices)
905 (project-headerline--register-hooks)
906 (force-mode-line-update))
907 ;; disable mode
908 (project-headerline--unregister-hooks)
909 (project-headerline--composer-remove 'project-headerline--compose)
910 (project-headerline--reset-buffer)
911 (force-mode-line-update)))
912
913;;;###autoload
914(define-globalized-minor-mode global-project-headerline-mode
915 project-headerline-mode
916 project-headerline--enable-maybe
917 :group 'project-headerline)
918
919(provide 'project-headerline)
920;;; project-headerline.el ends here