forked from rougier/nano-modeline
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathnano-modeline.el
1070 lines (901 loc) · 41.5 KB
/
nano-modeline.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
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; nano-modeline.el --- N Λ N O modeline -*- lexical-binding: t -*-
;; Copyright (C) 2021-2023 Free Software Foundation, Inc.
;; Maintainer: Nicolas P. Rougier <[email protected]>
;; URL: https://github.com/rougier/nano-modeline
;; Version: 1.0.1
;; Package-Requires: ((emacs "27.1"))
;; Keywords: convenience, mode-line, header-line
;; This file is not part of GNU Emacs.
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; For a full copy of the GNU General Public License
;; see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Nano modeline is a an alterntive to the GNU/Emacs modeline. It can
;; be displayed at the bottom (mode-line) or at the top (header-line)
;; depending on the nano-modeline-position custom setting. There are
;; several modelines that can be installed on a per-mode basis or as
;; the default one.
;;
;; Usage example:
;;
;; Install prog mode modeline:
;; (add-hook 'prog-mode-hook #'nano-modeline-prog-mode)
;;
;; Make text mode modeline the default:
;; (nano-modeline-text-mode t)
;;
;; Install all available modes:
;; (add-hook 'prog-mode-hook #'nano-modeline-prog-mode)
;; (add-hook 'text-mode-hook #'nano-modeline-text-mode)
;; (add-hook 'org-mode-hook #'nano-modeline-org-mode)
;; (add-hook 'pdf-view-mode-hook #'nano-modeline-pdf-mode)
;; (add-hook 'mu4e-headers-mode-hook #'nano-modeline-mu4e-headers-mode)
;; (add-hook 'mu4e-view-mode-hook #'nano-modeline-mu4e-message-mode)
;; (add-hook 'mu4e-compose-mode-hook #'nano-modeline-mu4e-compose-mode)
;; (add-hook 'elfeed-show-mode-hook #'nano-modeline-elfeed-entry-mode)
;; (add-hook 'elfeed-search-mode-hook #'nano-modeline-elfeed-search-mode)
;; (add-hook 'elpher-mode-hook #'nano-modeline-elpher-mode)
;; (add-hook 'term-mode-hook #'nano-modeline-term-mode)
;; (add-hook 'eat-mode-hook #'nano-modeline-eat-mode)
;; (add-hook 'xwidget-webkit-mode-hook #'nano-modeline-xwidget-mode)
;; (add-hook 'messages-buffer-mode-hook #'nano-modeline-message-mode)
;; (add-hook 'org-capture-mode-hook #'nano-modeline-org-capture-mode)
;; (add-hook 'org-agenda-mode-hook #'nano-modeline-org-agenda-mode)
;;
;;
;;; NEWS:
;;
;;
;; Version 1.1.0
;; - Minor bugfix with org-capture
;; - Better mu4e message mode line
;; - Fixed eat mode line
;; - Better margin/fringe alignment
;; - API change: button now take advantage of new svg-lib API
;; - Fixed flat-button style
;;
;; Version 1.0.1
;; - Minor bugfix
;;
;; Version 1.0.0
;; - Complete rewrite to make it simpler & faster
;; - API break: No longer a minor mode
;; - Activatable buttons can be added and grouped
;; - Modeline can be now be activated through modes hook
;;
;; Version 0.7.2
;; - Fix a bug in info mode (breadcrumbs)
;; - Fix mu header mode for version 1.8
;; - Put back padding (for default style)
;;
;; Version 0.7.1
;; - Fix a bug with mu4e-dashboard
;; - Fix a bug in pdf view mode
;; - Better org-capture mode
;;
;; Version 0.7
;; - Prefix is now an option (none, status or icon)
;; - Prefix can be replaced by icons
;; - Better space computation
;; - New imenu-list mode
;; - Indirect buffers are now handled properly
;; - Bugfix in org-clock-mode
;;
;; Version 0.6
;; - Spaces have face that enforce active/inactive
;; - Better marker for dedicated windows
;; - Internal reordering of modes, most frequent first
;; (educated guess, might vary greatly with users)
;;
;; Version 0.5.1
;; - Bug fix (make-obsolete-variable)
;; - Added marker for dedicated window
;;
;; Version 0.5
;; - Dynamic version that is now configurable thanks to the wonderful
;; contribution of Hans Donner (@hans-d)
;;
;; Version 0.4
;; - Reverted to RO/RW/** default prefix
;;
;; Version 0.3
;; - Usage of :align-to: properties for better alignment
;; - Added elpher mode
;; - Fix user mode
;;
;; Version 0.2
;; - Implements modeline as minor mode
;;
;; Version 0.1
;; - Submission to ELPA
;;
;;; Code:
(require 'cl-lib)
(defgroup nano nil
"N Λ N O"
:group 'convenience)
(defgroup nano-modeline nil
"N Λ N O Modeline"
:group 'nano)
(defcustom nano-modeline-padding '(0.20 . 0.25)
"Default vertical space adjustment (in fraction of character height)"
:type '(cons (float :tag "Top spacing")
(float :tag "Bottom spacing"))
:group 'nano-modeline)
(defcustom nano-modeline-position #'nano-modeline-header
"Default position for the nano modeline"
:type '(choice (const :tag "Top" nano-modeline-header)
(const :tag "Bottom" nano-modeline-footer))
:group 'nano-modeline)
(defcustom nano-modeline-window-dedicated-symbol '(" " . "")
"Pairs of strings showing a window is dedicated or not dedicated"
:type '(cons (string :tag "Window is dedicated" )
(string :tag "Window is not dedicated"))
:group 'nano-modeline)
(defface nano-modeline-active
`((t (:foreground ,(face-foreground 'default)
:background ,(face-background 'header-line nil t)
:box (:line-width 1 :color ,(face-background 'default)))))
"Face for when line is active")
(defface nano-modeline-inactive
`((t (:inherit (,(when (facep 'nano-faded) 'nano-faded)
nano-modeline-active))))
"Face for when line is inactive")
(defface nano-modeline-status
`((t (:foreground ,(face-background 'default)
:background ,(face-foreground 'shadow nil t)
:inherit bold)))
"Face for line status")
(defface nano-modeline-button-active-face
`((t :foreground ,(face-foreground 'default)
:background ,(face-background 'default)
:family "Roboto Mono"
:weight regular
:box (:line-width 2
:color ,(face-foreground 'default)
:style flat-button)))
"Active button face")
(defface nano-modeline-button-inactive-face
`((t :foreground ,(face-foreground (if (facep 'nano-faded) 'nano-faded 'default))
:background ,(face-background 'header-line nil t)
:family "Roboto Mono"
:weight regular
:box (:line-width 2
:color ,(face-foreground 'default)
:style flat-button)))
"Inactive button face.")
(defface nano-modeline-button-highlight-face
`((t :foreground ,(face-background 'default)
:background ,(face-foreground 'default)
:family "Roboto Mono"
:weight bold))
"Highlight button face.")
(defvar nano-modeline-base-face nil)
(defun nano-modeline--stroke-width (face)
"Extract the line width of the box for the given FACE."
(let* ((box (face-attribute face ':box nil 'default))
(width (plist-get box ':line-width)))
(cond ((integerp width) width)
((consp width) (car width))
(t 0))))
;; Nano line faces
(defcustom nano-modeline-faces
`((header-active . (nano-modeline-active))
(header-inactive . (nano-modeline-inactive))
(footer-active . (nano-modeline-active))
(footer-inactive . (nano-modeline-inactive))
(status-RW-active . (nano-modeline-status))
(status-RO-active . (nano-modeline-status))
(status-**-active . (nano-modeline-status
,(when (facep 'nano-popout-i) 'nano-popout-i)))
(name-active . (bold))
(primary-active . ())
(secondary-active . (,(when (facep 'nano-faded) 'nano-faded))))
"Nano line faces.
Each face defined here is used by the modeline depending on the current state (active / inactive). It is ok to define a face for a single state. In such case, the alternative state will use defaults."
:type '(alist :key-type (symbol :tag "Face")
:value-type (repeat :tag "inherits" face)))
(defface nano-modeline--empty-face
`((t (:foreground ,(face-foreground 'default))))
"Empty face for resetting mode-line / header-line."
:group nil)
(defvar nano-modeline--selected-window nil
"Selected window before mode-line was activated.")
(defun nano-modeline--update-selected-window ()
"Update selected window (before mode-line is active)"
(setq nano-modeline--selected-window (selected-window)))
(defun nano-modeline--base-face (face-prefix)
"Return the face for FACE-PREFIX according to current active state."
(let* ((window (get-buffer-window (current-buffer)))
(active (eq window nano-modeline--selected-window))
(state (intern (concat (symbol-name face-prefix)
(if active "-active" "-inactive"))))
(face (cadr (assoc state nano-modeline-faces))))
face))
(defun nano-modeline-face (&optional face-prefix)
"Return the face for FACE-PREFIX according to current active state and
make it inherit the base face."
(let* ((window (get-buffer-window (current-buffer)))
(active (eq window nano-modeline--selected-window))
(state (intern (concat (symbol-name face-prefix)
(if active "-active" "-inactive"))))
(face (cdr (assoc state nano-modeline-faces)))
(face (if nano-modeline-base-face
(push nano-modeline-base-face face)
face))
(face (reverse face)))
`(:inherit ,face)))
(defvar-local nano-modeline-left-fringe-width 0)
(defvar-local nano-modeline-right-fringe-width 0)
(defun nano-modeline--make (left right face-prefix)
"Build a dynamic mode/header line made of LEFT and RIGHT part,
using the given FACE-PREFIX as the default."
`(:eval
(let* ((nano-modeline-base-face (nano-modeline--base-face ',face-prefix))
(left (mapconcat
(lambda (element)
(if (stringp element)
(propertize element 'face nano-modeline-base-face)
(apply (car element) (cdr element))))
',left))
(right (mapconcat
(lambda (element)
(if (stringp element)
(propertize element 'face nano-modeline-base-face)
(apply (car element) (cdr element))))
',right))
(width (window-width))
(outside fringes-outside-margins)
(left-fringe (if outside -1.0 0.0))
(left-margin (if outside 0.0 1.0))
(right-fringe (if outside -1.0 0.0))
(right-margin (if outside -1.0 0.0))
(left-max-size (- width (length right) 2))
(left (if (> (length left) left-max-size)
(concat (truncate-string-to-width left left-max-size)
(propertize "…" 'face `(:inherit ,nano-modeline-base-face)))
left)))
(concat (propertize " "
'display `(space :align-to (+ left-margin
(,left-fringe . left-fringe)
(,left-margin . left-margin))))
(propertize " " 'face 'fringe
'display '(space :width (nano-modeline-left-fringe-width)))
left
(propertize " "
'face `(:inherit ,nano-modeline-base-face )
'display `(space :align-to (- right-margin
(,right-fringe . right-fringe)
(,right-margin . right-margin)
(nano-modeline-right-fringe-width)
,(length right))))
right
(propertize " " 'face 'fringe
'display '(space :width (nano-modeline-right-fringe-width)))))))
;; (defun nano-modeline--make (left right face-prefix)
;; "Build a dynamic mode/header line made of LEFT and RIGHT part,
;; using the given FACE-PREFIX as the default."
;; `(:eval
;; (let* ((nano-modeline-base-face (nano-modeline--base-face ',face-prefix))
;; (left (mapconcat
;; (lambda (element)
;; (if (stringp element)
;; (propertize element 'face nano-modeline-base-face)
;; (apply (car element) (cdr element))))
;; ',left))
;; (right (mapconcat
;; (lambda (element)
;; (if (stringp element)
;; (propertize element 'face nano-modeline-base-face)
;; (apply (car element) (cdr element))))
;; ',right))
;; (width (window-width))
;; (fringe (if fringes-outside-margins 0.0 -1.0))
;; (left-max-size (- width (length right) 2))
;; (left (if (> (length left) left-max-size)
;; (concat (truncate-string-to-width left left-max-size)
;; (propertize "…" 'face `(:inherit ,nano-modeline-base-face)))
;; left)))
;; (concat (propertize " "
;; 'display `(space :align-to (+ left-margin
;; (,fringe . left-fringe)
;; ( 0.0 . left-margin))))
;; left
;; (propertize " "
;; 'face `(:inherit ,nano-modeline-base-face)
;; 'display `(space :align-to (- right
;; (,fringe . right-fringe)
;; ( 0.0 . right-margin)
;; ,(length right))))
;; right))))
(defun nano-modeline--stroke-color (face)
"Extract the line color of the box for the given FACE."
(let* ((box (face-attribute face ':box))
(color (plist-get box ':color)))
(cond ((stringp color) color)
(t (face-foreground face nil 'default)))))
(defun nano-modeline--make-text-button (label face state)
"Make a text button from LABEL and FACE for given STATE."
(let* ((foreground (face-foreground face nil 'default))
(background (face-background face nil 'default))
(label (concat " " label " "))
;; We compensate the footer padding with an irregular outer
;; box around label (vertical border with a default
;; background color). If this is not made the background color
;; is the height of the modeline which is not very aesthetic.
(padding (floor (/ (* (frame-char-height)
(+ (car nano-modeline-padding)
(cdr nano-modeline-padding))) 2)))
(padding (+ padding 0))
(window (get-buffer-window (current-buffer)))
(active (eq window nano-modeline--selected-window))
(face (if active
'nano-modeline-active
'nano-modeline-inactive)))
(propertize label
'face `(:inherit ,face
:foreground ,foreground
:background ,background))))
(defvar nano-modeline--svg-button-cache nil
"Cache for modeline buttons")
(defun nano-modeline--make-svg-button (label face state)
"Make a svg button from LABEL and FACE for given STATE."
(require 'svg-lib)
(unless nano-modeline--svg-button-cache
(setq nano-modeline--svg-button-cache (make-hash-table :test 'equal)))
(with-memoization
(gethash (list label (get-text-property 0 'svg-faces label)
face state) nano-modeline--svg-button-cache)
(let* ((svg-faces (get-text-property 0 'svg-faces label))
(label-face (when svg-faces
(alist-get state svg-faces)))
(stroke (nano-modeline--stroke-width face))
(tag (if (facep label-face)
(svg-lib-tag label label-face :stroke stroke)
(apply #'svg-lib-tag label face label-face))) ;; :stroke stroke)))
(size (image-size tag))
(width (ceiling (car size))))
(propertize (make-string width ? ) 'display tag))))
(defun nano-modeline--make-button (button &optional use-svg)
"Make a button from a BUTTON decription. When USE-SVG is t and
svg-lib is installed, result is a SVG button else, it is a text
button."
(let* ((label (plist-get button :label))
(label (if (functionp label)
(funcall label)
label))
(state (plist-get button :state))
(help (plist-get button :help))
(hook (plist-get button :hook))
(window (get-buffer-window (current-buffer)))
(active (eq window nano-modeline--selected-window))
(face (cond ((not active) 'nano-modeline-button-inactive-face)
((eq state 'highlight) 'nano-modeline-button-highlight-face)
((eq state 'inactive) 'nano-modeline-button-inactive-face)
(t 'nano-modeline-button-active-face)))
(new-state (cond ((not active) 'inactive)
((eq state 'highlight) 'highlight)
((eq state 'inactive) 'inactive)
(t 'active)))
(button (if (and use-svg (package-installed-p 'svg-lib))
(nano-modeline--make-svg-button label face state)
(nano-modeline--make-text-button label face state))))
(propertize button
'pointer 'hand
'label label
'keymap (let ((map (make-sparse-keymap)))
(define-key map [header-line mouse-1] hook)
(define-key map [mode-line mouse-1] hook)
map)
'help-echo `(lambda (window object pos)
(nano-modeline--update-button-state ,label 'highlight)
(let (message-log-max)
(message ,help))
nil))))
(defun nano-modeline--reset-button-state (&rest args)
"Reset the state of all the buttons."
(when (boundp 'nano-modeline--buttons)
(dolist (buttons (mapcar 'cdr nano-modeline--buttons))
(dolist (button buttons)
(unless (eq (plist-get button :state) 'inactive)
(plist-put button :state 'active)))))
(force-mode-line-update))
(defun nano-modeline--update-button-state (label state)
"Update the state of the button LABEL with new STATE and update
other button states."
(let* ((window (get-buffer-window (current-buffer)))
(active (eq window nano-modeline--selected-window)))
(when (and active (boundp 'nano-modeline--buttons))
(dolist (buttons (mapcar 'cdr nano-modeline--buttons))
(dolist (button buttons)
(unless (eq (plist-get button :state) 'inactive)
(let* ((button-label (plist-get button :label))
(button-label (if (functionp button-label)
(funcall button-label)
button-label)))
(if (string-equal button-label label)
(plist-put button :state state)
(plist-put button :state 'active))))))))
(force-mode-line-update))
(defun nano-modeline-header (left &optional right default)
"Install a header line made of LEFT and RIGHT parts. Line can be
made DEFAULT."
(require 'tooltip)
(if default
(setq-default header-line-format (nano-modeline--make left right 'header))
(setq-local header-line-format (nano-modeline--make left right 'header)))
(make-local-variable 'nano-modeline--buttons)
(setq nano-modeline--buttons nil)
(advice-add 'tooltip-hide :before #'nano-modeline--reset-button-state)
(face-remap-set-base 'header-line 'nano-modeline--empty-face)
(add-hook 'post-command-hook #'nano-modeline--update-selected-window))
(defun nano-modeline-footer (left &optional right default)
"Install a footer line made of LEFT and RIGHT parts. Line can be
made DEFAULT."
(if default
(setq-default mode-line-format (nano-modeline--make left right 'header))
(setq-local mode-line-format (nano-modeline--make left right 'header)))
(make-local-variable 'nano-modeline--buttons)
(setq nano-modeline--buttons nil)
(advice-add 'tooltip-hide :before #'nano-modeline--reset-button-state)
(face-remap-set-base 'mode-line 'nano-modeline--empty-face)
(face-remap-set-base 'mode-line-inactive 'nano-modeline-empty-face)
(add-hook 'post-command-hook #'nano-modeline--update-selected-window))
(defun nano-modeline-buffer-name (&optional name)
"Buffer name"
(propertize
(cond (name name)
((buffer-narrowed-p) (format"%s [narrow]" (buffer-name)))
(t (buffer-name)))
'face (nano-modeline-face 'name)))
(defun nano-modeline-buffer-status (&optional status padding)
"Generic prefix to indicate buffer STATUS with vertical PADDING (top . bottom)"
(let* ((padding (or padding nano-modeline-padding))
(top (propertize " " 'display `(raise ,(car padding))))
(bot (propertize " " 'display `(raise ,(- (cdr padding))))))
(cond (buffer-read-only
(propertize (concat top (or status "RO") bot)
'face (nano-modeline-face 'status-RO)))
((buffer-modified-p)
(propertize (concat top (or status "**") bot)
'face (nano-modeline-face 'status-**)))
(t
(propertize (concat top (or status "RW") bot)
'face (nano-modeline-face 'status-RW))))))
(defun nano-modeline-buttons (buttons &optional use-svg group)
"Clickable BUTTONS in text or svg mode depending on
USE-SVG. BUTTONS is a list of cons (label. (hook . help)) where
hook is an interactive function that is called when the button is
clicked and help is the tooltip help message. GROUP (default to
0) is an arbitrary optional index of the group this button
belongs to.If you want to have button highlight when the mouse
hovers a button, tooltip mode needs to be active and tooltip
delay needs to be set to 0."
(unless (and (boundp 'nano-modeline--buttons)
nano-modeline--buttons
(assoc (or group 0) nano-modeline--buttons))
(unless (boundp 'nano-modeline--buttons)
(make-local-variable 'nano-modeline--buttons))
(let* ((group (or group 0))
(buttons (mapcar (lambda (button)
(list ':label (car button)
':state 'active
':help (cddr button)
':hook (cadr button)))
buttons)))
(if (cdr (assoc group nano-modeline--buttons))
(setf (cdr (assoc group nano-modeline--buttons)) buttons)
(add-to-list 'nano-modeline--buttons (cons group buttons)))))
(let* ((buttons (cdr (assoc (or group 0) nano-modeline--buttons)))
(buttons (if (and use-svg (package-installed-p 'svg-lib))
(mapconcat (lambda (button)
(nano-modeline--make-button button t))
buttons (propertize " " 'face (nano-modeline-face)))
(mapconcat (lambda (button)
(nano-modeline--make-button button nil))
buttons (propertize " " 'face (nano-modeline-face))))))
(if use-svg
(propertize buttons 'face (nano-modeline-face))
buttons)))
(defun nano-modeline-file-size ()
"File size in human readable format"
(if-let* ((file-name (buffer-file-name))
(file-attributes (file-attributes file-name))
(file-size (file-attribute-size file-attributes))
(file-size (file-size-human-readable file-size)))
(propertize (format "(%s)" file-size)
'face (nano-modeline-face 'primary))
""))
(defun nano-modeline-cursor-position (&optional format)
"Cursor position using given FORMAT."
(let ((format (or format "%l:%c ")))
(propertize (format-mode-line format)
'face (nano-modeline-face 'secondary))))
(defun nano-modeline-buffer-line-count ()
"Buffer total number of lines"
(save-excursion
(goto-char (point-max))
(propertize
(format-mode-line "(%l lines)")
'face (nano-modeline-face 'primary))))
(defun nano-modeline-window-dedicated (&optional dedicated not-dedicated)
"Pin symbol when window is dedicated"
(propertize (if (window-dedicated-p)
(or dedicated (car nano-modeline-window-dedicated-symbol))
(or not-dedicated (cdr nano-modeline-window-dedicated-symbol)))
'face (nano-modeline-face 'secondary)))
(defun nano-modeline-git-info (&optional symbol)
"Git information as (branch, file status)"
(when vc-mode
(when-let* ((file (buffer-file-name))
(branch (substring-no-properties vc-mode 5))
(state (vc-state file)))
(propertize (format "(%s%s, %s)" (or symbol " ") branch state)
'face (nano-modeline-face 'primary)))))
(defun nano-modeline-primary-info (text)
"Information using primary face"
(propertize text 'face (nano-modeline-face 'primary)))
(defun nano-modeline-secondary-info (text)
"Information using primary face"
(propertize text 'face (nano-modeline-face 'secondary)))
(defun nano-modeline-mu4e-search-filter ()
"Mu4e current search"
(propertize (mu4e-last-query) 'face (nano-modeline-face 'name)))
(defun nano-modeline-mu4e-context ()
"Mu4e current context"
(let* ((context (mu4e-context-current))
(name (if context (mu4e-context-name context) "none")))
(propertize (format "[%s] " name)
'face (nano-modeline-face 'secondary))))
(defun nano-modeline-mu4e-raw-context ()
"Mu4e current context (raw form for button)"
(let* ((context (mu4e-context-current))
(name (if context (mu4e-context-name context) "NONE")))
(upcase name)))
(defun nano-modeline-mu4e-message-to ()
"Return the recipients of a message, separating me from others"
(with-current-buffer "*mu4e-headers*"
(let* ((msg (mu4e-message-at-point))
(list (memq 'list (plist-get msg :flags)))
(cc (mapcar (lambda (item)
(downcase (plist-get item :email)))
(plist-get msg :cc)))
(to (mapcar (lambda (item)
(downcase (plist-get item :email)))
(plist-get msg :to)))
(to-names (mapcar (lambda (item)
(if (stringp (plist-get item :name))
(capitalize (downcase (plist-get item :name)))
(plist-get item :email)))
(plist-get msg :to)))
(all (cl-union to cc))
(me (mapcar #'downcase (mu4e-personal-addresses)))
(me (cl-intersection all me :test #'string-equal))
(others (cl-set-difference all me :test #'string-equal)))
(cond (list
(concat "to " (car to-names)))
((= (length others) 0)
"to me")
((and (> (length others) 0) (< (length others) (length all)))
(format "to me (+%d recipients)" (length others)))
((and (= (length others) 1))
(format "to %s" (car to-names)))
(t
(format "to %s (+%d recipients)" (car to-names) (1- (length others))))))))
(defun nano-modeline-mu4e-message-from ()
"Return the sender of the message that can be me or a name"
(with-current-buffer "*mu4e-headers*"
(let* ((msg (mu4e-message-at-point))
(me (mapcar #'downcase (mu4e-personal-addresses)))
(from (mu4e-message-field msg :from))
(from-name (plist-get (car from) :name))
(from-email (plist-get (car from) :email)))
(cond ((member from-email me) "Me")
((stringp from-name) (capitalize (downcase from-name)))
(t from-email)))))
(defun nano-modeline-mu4e-view-in-xwidget ()
(interactive)
(with-current-buffer "*mu4e-headers*"
(let ((msg (mu4e-message-at-point)))
(mu4e-action-view-in-xwidget msg))))
(defun nano-modeline-mu4e-context-next ()
"Switch to next mu4e context"
(interactive)
(let* ((current (mu4e-context-name (mu4e-context-current)))
(contexts (mapcar (lambda (context)
(mu4e-context-name context))
mu4e-contexts))
(index (mod (1+ (cl-position current contexts))
(length contexts)))
(current (nth index contexts)))
(mu4e-context-switch t current)))
(defun nano-modeline-mu4e-message-subject ()
"Mu4e message subject"
(let* ((msg (mu4e-message-at-point))
(subject (mu4e-message-field msg :subject)))
(propertize (format "%s" subject)
'face (nano-modeline-face 'name))))
(defun nano-modeline-mu4e-message-date ()
"Mu4e message date"
(let* ((msg (mu4e-message-at-point))
(date (mu4e-message-field msg :date)))
(propertize (format-time-string "%d %b %Y at %H:%M" date)
'face (nano-modeline-face 'secondary))))
(defun nano-modeline-pdf-page ()
"PDF view mode page number / page total"
(let ((page-current (image-mode-window-get 'page))
(page-total (pdf-cache-number-of-pages)))
(propertize (format "%d/%d " page-current page-total)
'face (nano-modeline-face 'secondary))))
(defun nano-modeline-elfeed-entry-status ()
"Elfeed entry status"
(let* ((feed (elfeed-entry-feed elfeed-show-entry))
(feed-title (plist-get (elfeed-feed-meta feed) :title)))
(nano-modeline-buffer-status feed-title)))
(defun nano-modeline-elfeed-entry-title ()
"Elfeed entry title"
(let* ((title (elfeed-entry-title elfeed-show-entry))
(title (string-replace "%" "%%" title)))
(propertize title 'face (nano-modeline-face 'name))))
(defun nano-modeline-elfeed-search-filter ()
"Elfeed search filter"
(propertize
(if (and (not (zerop (elfeed-db-last-update)))
(> (elfeed-queue-count-total) 0))
(let ((total (elfeed-queue-count-total))
(in-process (elfeed-queue-count-active)))
(format "%d jobs pending, %d active" (- total in-process) in-process))
(cond (elfeed-search-filter-active "")
((string-match-p "[^ ]" elfeed-search-filter) elfeed-search-filter)
(t "")))
'face (nano-modeline-face 'name)))
(defun nano-modeline-elfeed-search-count ()
"Elfeed search statistics"
(propertize (cond ((zerop (elfeed-db-last-update)) "")
((> (elfeed-queue-count-total) 0) "")
(t (concat (elfeed-search--count-unread) " ")))
'face (nano-modeline-face 'secondary)))
(defun nano-modeline-elpher-protocol ()
"Elpher protocol"
(propertize (format "(%s)"
(elpher-address-protocol (elpher-page-address elpher-current-page)))
'face (nano-modeline-face 'primary)))
(defun nano-modeline-elpher-title ()
"Elpher protocol"
(propertize
(elpher-page-display-string elpher-current-page)
'face (nano-modeline-face 'name)))
(defun nano-modeline-date (&optional date format)
"Date using given FORMAT and DATE"
(propertize (format-time-string (or format "%A %-e %B %Y") date)
'face (nano-modeline-face 'secondary)))
(defun nano-modeline-org-agenda-date (&optional format)
"Date at point in org agenda using given FORMAT"
(when-let* ((day (or (org-get-at-bol 'ts-date)
(org-get-at-bol 'day)))
(date (calendar-gregorian-from-absolute day))
(day (nth 1 date))
(month (nth 0 date))
(year (nth 2 date))
(date (encode-time 0 0 0 day month year)))
(propertize (format-time-string (or format "%A %-e %B %Y") date)
'face (nano-modeline-face 'secondary))))
(defun nano-modeline-term-shell-name ()
"Term shell name"
(propertize shell-file-name
'face (nano-modeline-face 'name)))
(defun nano-modeline-term-shell-mode ()
"Term shell mode"
(propertize (if (term-in-char-mode)
"(char mode)"
"(line mode)")
'face (nano-modeline-face 'primary)))
(defun nano-modeline-eat-shell-mode ()
"Eat shell mode"
(propertize (cond (eat--semi-char-mode "(semi-char mode)")
(eat--char-mode "(char mode)")
(eat--line-mode "(line mode)")
(t "(unknown mode)"))
'face (nano-modeline-face 'primary)))
(defun nano-modeline-default-directory (&optional max-length)
"Term current directory"
(let* ((max-length (or max-length 32))
(dir default-directory)
(path (reverse (split-string (abbreviate-file-name dir) "/")))
(output ""))
(when (and path (equal "" (car path)))
(setq path (cdr path)))
(while (and path (< (length output) (- max-length 0)))
(setq output (concat (car path) "/" output))
(setq path (cdr path)))
(when path
(setq output (concat "…/" output)))
(propertize output 'face (nano-modeline-face 'secondary))))
(defun nano-modeline-xwidget-uri ()
"xwidget URI"
(propertize (xwidget-webkit-uri (xwidget-at (point-min)))
'face (nano-modeline-face 'name)))
(defun nano-modeline-org-buffer-name (&optional name)
"Org buffer name"
(propertize
(cond (name
name)
((buffer-narrowed-p)
(format"%s [%s]" (or (buffer-base-buffer) (buffer-name))
(org-link-display-format
(substring-no-properties
(or (org-get-heading 'no-tags) "-")))))
(t
(buffer-name)))
'face (nano-modeline-face 'name)))
(defun nano-modeline-org-outline-path ()
"Org outline path"
(let ((path (org-with-point-at (org-get-at-bol 'org-marker)
(org-display-outline-path nil nil " » " t))))
(propertize (substring-no-properties path)
'face (nano-modeline-face 'name))))
(defun nano-modeline-org-capture-description ()
"Org capture descrioption"
(let* ((header (nth 4 (org-heading-components)))
(header (or header ""))
(header (org-link-display-format header))
(header (replace-regexp-in-string org-ts-regexp3 "" header))
(header (string-trim header))
(header (substring-no-properties header)))
(propertize (format "(%s)" header)
;; (format "(%s)" (substring-no-properties (org-capture-get :description)))
'face (nano-modeline-face 'primary))))
(defun nano-modeline-prog-mode (&optional default)
"Nano line for prog mode. Can be made DEFAULT mode."
(funcall nano-modeline-position
'((nano-modeline-buffer-status) " "
(nano-modeline-buffer-name) " "
(nano-modeline-git-info))
'((nano-modeline-cursor-position)
(nano-modeline-window-dedicated))
default))
(defun nano-modeline-text-mode (&optional default)
"Nano line for text mode. Can be made DEFAULT mode."
(funcall nano-modeline-position
'((nano-modeline-buffer-status) " "
(nano-modeline-buffer-name) " "
(nano-modeline-git-info))
'((nano-modeline-cursor-position)
(nano-modeline-window-dedicated))
default))
(defun nano-modeline-elpher-mode ()
"Nano line for elpher mode"
(setq elpher-use-header nil)
(funcall nano-modeline-position
'((nano-modeline-buffer-status "GEM") " "
(nano-modeline-elpher-title) " "
(nano-modeline-elpher-protocol))
'((nano-modeline-cursor-position)
(nano-modeline-window-dedicated))))
(defun nano-modeline-org-mode ()
"Nano line for org mode"
(funcall nano-modeline-position
'((nano-modeline-buffer-status) " "
(nano-modeline-org-buffer-name) " "
(nano-modeline-git-info))
'((nano-modeline-cursor-position)
(nano-modeline-window-dedicated))))
(defun nano-modeline-pdf-mode ()
"Nano line for text mode"
(funcall nano-modeline-position
'((nano-modeline-buffer-status "PDF") " "
(nano-modeline-buffer-name) " "
(nano-modeline-file-size))
'((nano-modeline-pdf-page)
(nano-modeline-window-dedicated))))
(defun nano-modeline-mu4e-headers-mode ()
"Nano line for mu4e headers mode with a button to change context"
(let ((buttons '((nano-modeline-mu4e-raw-context . (nano-modeline-mu4e-context-next . "Switch to next context")))))
(funcall nano-modeline-position
'((nano-modeline-buffer-status "MAIL") " "
(nano-modeline-mu4e-search-filter))
`((nano-modeline-buttons ,buttons t) " "
(nano-modeline-window-dedicated)))))
(defun nano-modeline-mu4e-message-mode ()
"Nano line for mu4e message mode with several buttons for most
common action"
(let ((buttons '(("[bootstrap:archive]" . (mu4e-view-mark-for-refile . "Archive message"))
(":bootstrap:trash]" . (mu4e-view-mark-for-trash . "Delete message"))
("[bootstrap:file-richtext]". (nano-modeline-mu4e-view-in-xwidget . "View message as HTML"))
("[bootstrap:folder]". (mu4e-headers-mark-for-move . "Move message"))
("[bootstrap:tag]". (mu4e-headers-mark-for-tag . "Tag message"))
("[bootstrap:reply]". (mu4e-compose-reply . "Reply to message"))
("[bootstrap:forward]". (mu4e-compose-forward . "Forward message")))))
(funcall nano-modeline-position
`((nano-modeline-buffer-status "FROM") " "
(nano-modeline-buffer-name ,(nano-modeline-mu4e-message-from)) " "
(nano-modeline-primary-info ,(nano-modeline-mu4e-message-to)))
`((nano-modeline-mu4e-message-date) " "
;; (nano-modeline-buttons ,buttons t) " "
(nano-modeline-window-dedicated)))))
(defun nano-modeline-mu4e-compose-mode ()
"Nano line for mu4e compose mode"
(let ((buttons '(("[bootstrap:download]" . (save-buffer . "Save message"))
("[bootstrap:paperclip]" . (mml-attach-file . "Attach file"))
("[bootstrap:lock]" . (mml-secure-message-encrypt . "Encrypt message"))
("[bootstrap:check]" . (mml-secure-message-sign . "Sign message"))
("[bootstrap:send]" . (message-send-and-exit . "Send message")))))
(funcall nano-modeline-position
`((nano-modeline-buffer-status "DRAFT") " "
(nano-modeline-buffer-name "Message"))
`((nano-modeline-buttons ,buttons t) " "
(nano-modeline-window-dedicated)))))
(defun nano-modeline-elfeed-entry-mode ()
"Nano line for elfeed entry mode"
(funcall nano-modeline-position
'((nano-modeline-elfeed-entry-status) " "
(nano-modeline-elfeed-entry-title))))
(defun nano-modeline-elfeed-search-mode ()
"Nano line for elfeed search mode"
(add-hook 'elfeed-search-update-hook #'force-mode-line-update)
(funcall nano-modeline-position
'((nano-modeline-buffer-status "NEWS") " "
(nano-modeline-elfeed-search-filter))