-
Notifications
You must be signed in to change notification settings - Fork 1
/
jmt-mode.el
2514 lines (2060 loc) · 120 KB
/
jmt-mode.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
;;; jmt-mode.el --- JMT Mode -*- lexical-binding: t; -*-
;; Copyright © 2019-2024 Michael Allan.
;;
;; Author: Michael Allan <mike@reluk.ca>
;; Version: 0-snapshot
;; SPDX-License-Identifier: MIT
;; Package-Requires: ((emacs "27.1"))
;; Keywords: languages, c
;; URL: http://reluk.ca/project/Java/Emacs/
;;
;; This file is not part of GNU Emacs.
;;
;; This file is released under an MIT licence. A copy of the licence normally accompanies it.
;; If not, then see `http://reluk.ca/project/Java/Emacs/LICENCE.txt`.
;;; Commentary:
;; This package implements JMT Mode, a major mode that affords better control
;; of Emacs’s Java mode, particularly in regard to syntax highlighting.
;; For more information, see `http://reluk.ca/project/Java/Emacs/`.
;;
;; Installation
;;
;; If you installed this package from MELPA using a package manager, then already JMT Mode
;; should activate for any loaded file that has either a `.java` extension or `java` shebang.
;; Alternatively, you may want to install it manually:
;;
;; 1. Put a copy of the file `jmt-mode.el` on your load path.
;; https://www.gnu.org/software/emacs/manual/html_node/elisp/Library-Search.html
;;
;; 2. Optionally compile that copy. Load it into an Emacs buffer, for example,
;; and type `M-x emacs-lisp-byte-compile`.
;;
;; 3. Add the following code to your Emacs initialization file.
;;
;; (autoload 'jmt-mode "jmt-mode" nil t)
;; (set 'auto-mode-alist (cons (cons "\\.java\\'" 'jmt-mode) auto-mode-alist))
;; (set 'interpreter-mode-alist; For Java source-launch files encoded with a shebang. [SLS]
;; (cons (cons "\\(?:--split-string=\\|-S\\)?java" 'jmt-mode)
;; interpreter-mode-alist))
;; (register-definition-prefixes "jmt-mode" '("jmt-"))
;;
;; For a working example, see the relevant lines of `http://reluk.ca/.config/emacs/initialization.el`.
;;
;; Customization
;;
;; To see a list of customizeable faces, enter a JMT Mode buffer, or otherwise load JMT Mode,
;; and type `M-x customize-group <RET> jmt <RET>`. Alternatively, look through the `defface`
;; definitions of file `jmt-mode.el`.
;;
;; For a working example, see:
;;
;; • The author’s initialization file — http://reluk.ca/.config/emacs/initialization.el
;; • The author’s `~/.Xresources` — http://reluk.ca/.Xresources
;;
;; Changes made to Emacs
;;
;; This package applies monkey patches to the runtime session that redefine parts of built-in packages
;; CC Mode and Font Lock. The patches are applied on first entrance to JMT Mode. Most of them apply
;; to function definitions, in which case they are designed to leave the behaviour of Emacs unchanged
;; in all buffers except those running JMT Mode. The patched functions are:
;;
;; c-before-change
;; c-fontify-recorded-types-and-refs
;; c-font-lock-<>-arglists
;; c-font-lock-declarations
;; c-font-lock-doc-comments
;; font-lock-fontify-region-function
;;
;; Moreover, one variable is patched:
;;
;; javadoc-font-lock-doc-comments - To allow for upper case letters in Javadoc block tags.
;;; Code:
;; The `Package-Requires` version of Emacs (above) was obtained from `package-lint-current-buffer`.
(eval-when-compile (require 'cl-lib)); Built into Emacs since version 24.3.
(require 'cc-mode); Among other programming modes, it defines Java Mode.
;;; https://www.gnu.org/software/emacs/manual/html_node/ccmode/index.html
;; ══════════════════════════════════════════════════════════════════════════════════════════════════════
;; P r e l i m i n a r y d e c l a r a t i o n s
;; ══════════════════════════════════════════════════════════════════════════════════════════════════════
(defun jmt-make-Javadoc-tag-facing (f)
"Make a face property for a Javadoc tag using face F (symbol) as a base."
(list f 'font-lock-doc-face)); [PJF]
(defconst jmt-name-character-set "[:alnum:]_$"
"The set of characters from which a Java identifier may be formed.")
;;; https://docs.oracle.com/javase/specs/jls/se15/html/jls-3.html#jls-3.8
;; ══════════════════════════════════════════════════════════════════════════════════════════════════════
;; D e c l a r a t i o n s i n l e x i c o g r a p h i c o r d e r
;; ══════════════════════════════════════════════════════════════════════════════════════════════════════
(defgroup delimiter-faces nil
"Faces for Java separators and other delimiters."
:group 'jmt
:prefix "jmt-")
(defgroup javadoc-faces nil
"Faces for Java API descriptions."
:group 'jmt
:prefix "jmt-")
(defgroup jmt nil
"A major mode affording better control of Emacs's Java mode."
:group 'languages :group 'faces
:prefix "jmt-"
:tag "JMT"
:link '(url-link "http://reluk.ca/project/Java/Emacs/"))
(defface jmt-angle-bracket `((t . (:inherit jmt-bracket)))
"The face for an angle bracket, \\=`<\\=` or \\=`>\\=`."
:group 'delimiter-faces)
(defface jmt-annotation-delimiter; This non-replacement face inherits from `c-annotation-face` only
;;; for sake of `jmt-is-annotation-terminal-face` and replacement subface `jmt-annotation-mark`.
`((t . (:inherit c-annotation-face)))
"The face for the \\=`@\\=`, \\=`(\\=` and \\=`)\\=` delimiters of annotation.
Customize it to better distinguish the delimiters from the content
they delimit; making them more prominent or less prominent, for example.
See also `jmt-delimiter' and the faces that inherit from it."
:group 'delimiter-faces)
(defface jmt-annotation-mark; [RF]
`((t . (:inherit jmt-annotation-delimiter)))
"The face for the \\=`@\\=` symbol denoting annotation."
:group 'delimiter-faces)
(defface jmt-annotation-package-name; [MDF, RF]
`((t . (:inherit jmt-package-name)))
"The face for each segment of a package name in an annotation type reference.
It defaults to `jmt-package-name'; customize it if the default fits poorly
with your other annotation faces."
:group 'jmt)
(defface jmt-annotation-string; [BC, LF, RF]
`((t . (:inherit font-lock-string-face)))
"The face for a string in an annotation qualifier.
It defaults to `font-lock-string-face'; customize it if the default fits poorly
with your other annotation faces."
:group 'jmt)
(defface jmt-annotation-string-delimiter; [BC, LF, RF]
`((t . (:inherit jmt-string-delimiter)))
"The face for a string delimiter in an annotation qualifier.
It defaults to `jmt-string-delimiter'; customize it if the default fits poorly
with your other annotation faces."
:group 'delimiter-faces)
(defface jmt-annotation-qualifier `((t . (:inherit c-annotation-face)))
"The face for the element assignments of annotation.
Customize it e.g. to give the assignments less prominence
than the `c-annotation-face' of the preceding type name."
:group 'jmt)
(defface jmt-block-tag-name; [NDF, RF]
`((t . (:inherit jmt-Javadoc-tag-name)))
"The face for the proper identifier of a Javadoc block tag."
:group 'javadoc-faces)
(defconst jmt-block-tag-name-f (jmt-make-Javadoc-tag-facing 'jmt-block-tag-name))
(defface jmt-block-tag-parameter; [CI]
`((t . (:inherit font-lock-doc-face)))
"The face for a non-descriptive parameter of a Javadoc block tag.
See also subfaces `jmt-param-tag-parameter' and `jmt-throws-tag-parameter'."
:group 'javadoc-faces)
(defface jmt-boilerplate-keyword; [MDF, RF]
`((t . (:inherit jmt-principal-keyword)))
"The face for the keyword of a formal Java declaration in the preamble of a compilation unit."
:group 'keyword-faces)
(defface jmt-bracket `((t . (:inherit jmt-delimiter)))
"The face for a bracket.
See also `jmt-angle-bracket', `jmt-curly-bracket', `jmt-round-bracket' and `jmt-square-bracket'."
:group 'delimiter-faces)
(defun jmt--c-put-face-tamed (beg end face)
"Call `c-put-font-lock-face' with BEG END constrained to a valid region.
The given region is never constrained when `jmt-mode' is inactive, in which
case the call is simply passed through as \\=`c-put-font-lock-face BEG END FACE\\=`.
Otherwise, before calling \\=`c-put-font-lock-face\\=`, BEG and END are clipped
to the region presently under fontification by Font Lock."
(defvar jmt--is-level-3); [FV]
(defvar jmt--present-fontification-beg)
(defvar jmt--present-fontification-end)
(if (and jmt--is-level-3
(eq major-mode 'jmt-mode))
(progn
(setq beg (max beg jmt--present-fontification-beg)
end (min end jmt--present-fontification-end))
(when (< beg end) (c-put-font-lock-face beg end face)))
(c-put-font-lock-face beg end face)))
(defun jmt--c-put-face-unless-wild (beg end face)
"Call `c-put-font-lock-face' on condition BEG END delimits a valid region.
The given region is always judged valid when `jmt-mode' is inactive, in which
case the call is simply passed through as \\=`c-put-font-lock-face BEG END FACE\\=`.
Otherwise the call is passed through only if BEG and END lie within the region
presently under fontification by Font Lock."
(defvar jmt--is-level-3); [FV]
(defvar jmt--present-fontification-beg)
(defvar jmt--present-fontification-end)
(if (and jmt--is-level-3
(eq major-mode 'jmt-mode))
(unless (or
(> end jmt--present-fontification-end)
(< beg jmt--present-fontification-beg))
(c-put-font-lock-face beg end face))
(c-put-font-lock-face beg end face)))
(defface jmt-curly-bracket `((t . (:inherit jmt-bracket)))
"The face for a curly bracket, \\=`{\\=` or \\=`}\\=`."
:group 'delimiter-faces)
(defface jmt-delimiter nil
"The face for a delimiter not already faced by Java Mode.
Customize it to better distinguish the delimiters from the content they delimit;
making them more prominent or less prominent, for example. See also subfaces
`jmt-bracket', `jmt-separator'. And for delimiters that *are* already faced
by Java Mode, see `jmt-annotation-delimiter', `jmt-annotation-mark',
`jmt-string-delimiter' and `font-lock-comment-delimiter-face'."
:group 'delimiter-faces)
(defvar jmt--early-initialization-was-begun nil)
(defface jmt-expression-keyword; [MDF, RF]
`((t . (:inherit jmt-principal-keyword)))
"The face for the keyword of an operator or other element of a formal Java expression."
:group 'keyword-faces)
(defvar jmt-f); [GVF]
(defun jmt-faces-are-equivalent (f1 f2)
"Tell whether Java Mode should treat face symbols F1 and F2 as equivalent."
(eq (jmt-untamed-face f1) (jmt-untamed-face f2))); [RF]
(defface jmt-HTML-end-tag-name; [NDF, RF]
`((t . (:inherit jmt-HTML-tag-name)))
"The face for the tag name in the end tag of an HTML element in a Javadoc comment."
:group 'javadoc-faces)
(defconst jmt-HTML-end-tag-name-f (jmt-make-Javadoc-tag-facing 'jmt-HTML-end-tag-name))
(defface jmt-HTML-start-tag-name; [NDF, RF]
`((t . (:inherit jmt-HTML-tag-name)))
"The face for the tag name in the start tag of an HTML element in a Javadoc comment."
:group 'javadoc-faces)
(defconst jmt-HTML-start-tag-name-f (jmt-make-Javadoc-tag-facing 'jmt-HTML-start-tag-name))
(defface jmt-HTML-tag-name; [NDF, RF]
`((t . (:inherit jmt-Javadoc-tag-name)))
"The face for the tag name of an HTML element in a Javadoc comment.
See also subfaces `jmt-HTML-start-tag-name' and `jmt-HTML-end-tag-name'."
:group 'javadoc-faces)
(defconst jmt-identifier-pattern (concat "[" jmt-name-character-set "]+")
"The regular-expression pattern of a Java identifier.")
(defface jmt-inline-rendered-parameter; [NDF, RF]
`((t . (:inherit jmt-inline-tag-parameter)))
"The face for a rendered parameter of a Javadoc in-line tag.
One that appears more-or-less literally in the resulting Javadocs, that is."
:group 'javadoc-faces)
(defconst jmt-inline-rendered-parameter-f (jmt-make-Javadoc-tag-facing 'jmt-inline-rendered-parameter))
(defface jmt-inline-tag-name; [NDF, RF]
`((t . (:inherit jmt-Javadoc-tag-name)))
"The face for the proper identifier of a Javadoc in-line tag."
:group 'javadoc-faces)
(defconst jmt-inline-tag-name-f (jmt-make-Javadoc-tag-facing 'jmt-inline-tag-name))
(defface jmt-inline-tag-parameter; [NDF, RF]
`((t . (:inherit jmt-Javadoc-tag)))
"The face for a parameter of a Javadoc in-line tag, or attribute of an HTML tag.
See also subface `jmt-inline-rendered-parameter'. And for block tags,
see `jmt-block-tag-parameter'."
:group 'javadoc-faces)
(defconst jmt-inline-tag-parameter-f (jmt-make-Javadoc-tag-facing 'jmt-inline-tag-parameter))
(defun jmt-is-annotation-ish-before (p)
"Tell whether the position before P (integer) might be within annotation."
(let ((f (get-text-property (1- p) 'face)))
(or (eq 'c-annotation-face (jmt-untamed-face f))
(eq 'jmt-annotation-string f)
(eq 'jmt-annotation-string-delimiter f)
(eq 'jmt-annotation-package-name f); A package name in an annotation type reference.
(and (eq 'jmt-separator f) (= ?. (char-before p)))))); A dot `.` in the package name.
(defun jmt-is-annotation-terminal-face (f)
"Tell whether face F (symbol) might occur on the last character of annotation."
(eq 'c-annotation-face (jmt-untamed-face f)))
(defun jmt-is-Java-Mode-tag-faced (p)
"Tell whether face property P (symbol or list) might occur on a Javadoc tag."
(and (consp p); Testing for precisely `(font-lock-doc-markup-face font-lock-doc-face)`. [PJF]
(eq 'font-lock-doc-markup-face (car p))
(eq 'font-lock-doc-face (car (setq p (cdr p))))
(null (cdr p))))
(defun jmt-is-Java-Mode-type-face (f)
"Tell whether face F (symbol) is a type face that Java Mode might have set."
(eq f 'font-lock-type-face)); Java Mode sets this face alone.
(defvar-local jmt--is-level-3 nil); An in-buffer cache of this boolean flag. It works only because any
;;; ‘customization of `font-lock-maximum-decoration` should be done *before* the file is visited’.
;;; https://www.gnu.org/software/emacs/manual/html_node/emacs/Font-Lock.html
(defun jmt-is-type-declarative-keyword (s)
"Tell whether string S is the principal keyword of a type declaration."
(or (string= s "class")
(string= s "interface")
(string= s "enum")
(string= s "record")));
(defun jmt-is-type-modifier-keyword (s)
"Tell whether string S is a type declaration modifier in keyword form."
;; Keyword form as opposed e.g. to annotation form, that is."
;; `ClassModifier` https://docs.oracle.com/javase/specs/jls/se15/html/jls-8.html#jls-8.1.1
;; `InterfaceModifier` https://docs.oracle.com/javase/specs/jls/se15/html/jls-9.html#jls-9.1.1
(or (string= s "public")
(string= s "final")
(string= s "static")
(string= s "private")
(string= s "abstract")
(string= s "protected")
(string= s "srictfp")))
(defface jmt-Javadoc-outer-delimiter; [CI]
`((t . (:inherit font-lock-doc-face)))
"The face for the outer delimiters of a Javadoc comment.
These comprise the outermost delimiters \\=`/**\\=` and \\=`*/\\=` that between
them contain the Javadoc comment, and the left-marginal asterisks \\=`*\\=`
that may lead any of its lines. Customize this face to better distinguish
these delimiters from the content they delimit; making them more prominent
or less prominent, for example."
:group 'delimiter-faces :group 'javadoc-faces)
(defface jmt-Javadoc-tag; [NDF, RF]
`((t . (:inherit font-lock-doc-markup-face)))
"The face for a Javadoc or HTML tag embedded in a Javadoc comment.
It inherits from `font-lock-doc-markup-face'; customize it to distinguish
Javadoc tags from other constructs that use `font-lock-doc-markup-face'.
See also subfaces `jmt-Javadoc-tag-delimiter', `jmt-Javadoc-tag-name'
and `jmt-inline-tag-parameter'."
:group 'javadoc-faces)
(defface jmt-Javadoc-tag-delimiter; [NDF, RF]
`((t . (:inherit jmt-Javadoc-tag)))
"The face for the delimiters of a Javadoc tag.
These comprise the \\=`@\\=`, \\=`{\\=` and \\=`}\\=` delimiters of a Javadoc tag,
and the \\=`<\\=`, \\=`</\\=`, \\=`/>\\=` and \\=`>\\=` delimiters of an HTML tag.
Customize this face to better distinguish these delimiters from the content
they delimit; making them more prominent or less prominent, for example.
See also subface `jmt-Javadoc-tag-mark'."
:group 'javadoc-faces)
(defconst jmt-Javadoc-tag-delimiter-f (jmt-make-Javadoc-tag-facing 'jmt-Javadoc-tag-delimiter))
(defface jmt-Javadoc-tag-mark; [NDF, RF]
`((t . (:inherit jmt-Javadoc-tag-delimiter)))
"The face for the \\=`@\\=` symbol denoting a Javadoc tag."
:group 'javadoc-faces)
(defconst jmt-Javadoc-tag-mark-f (jmt-make-Javadoc-tag-facing 'jmt-Javadoc-tag-mark))
(defface jmt-Javadoc-tag-name; [NDF, RF]
`((t . (:inherit jmt-Javadoc-tag)))
"The face for the proper identifier of a Javadoc or HTML tag.
See also subfaces `jmt-block-tag-name', `jmt-inline-tag-name'
and `jmt-HTML-tag-name'."
:group 'javadoc-faces)
(defconst jmt-Javadoc-tag-name-f (jmt-make-Javadoc-tag-facing 'jmt-Javadoc-tag-name))
(defun jmt-keyword-face (keyword beg end)
"The face (symbol) proper to a Java KEYWORD (string).
The keyword extends from buffer position BEG (number, inclusive)
to END (exclusive). Point is left indeterminate."
(defvar jmt-keyword-face-alist); [FV]
(let ((f (assoc keyword jmt-keyword-face-alist)))
(if (not f) 'jmt-principal-keyword; Giving either a default face,
(setq f (cdr f)) ; or, from `jmt-keyword-face-alist`,
(if (not (functionp f)) f ; a face either directly named
(funcall f beg end))))) ; or got from a named function.
(defconst jmt-keyword-face-alist
'(
;; Frequent
;; ────────
("assert" . jmt-principal-keyword); Of a statement.
;;; ("boolean" . jmt-type-keyword); (but faced rather as a type by Java Mode)
("break" . jmt-principal-keyword); Of a statement.
("else" . jmt-principal-keyword); Of a statement clause.
("final" . jmt-qualifier-keyword)
("if" . jmt-principal-keyword); Of a statement.
("import" . jmt-boilerplate-keyword)
;;; ("int" . jmt-type-keyword); (but faced rather as a type by Java Mode)
;;; ("long" . jmt-type-keyword); (but faced rather as a type by Java Mode)
("private" . jmt-qualifier-keyword)
("public" . jmt-qualifier-keyword)
("return" . jmt-principal-keyword); Of a statement.
("static" . jmt-keyword-face-static); (q.v.)
;; Infrequent; typically a few times per buffer
;; ──────────
("abstract" . jmt-qualifier-keyword)
("case" . jmt-principal-keyword); Of a statement clause.
("catch" . jmt-principal-keyword); Of a statement clause.
;;; ("char" . jmt-type-keyword); (but faced rather as a type by Java Mode)
("class" . jmt-keyword-face-class); (q.v.)
("continue" . jmt-principal-keyword); Of a statement.
("default" . jmt-keyword-face-default); (q.v.)
;;; ("float" . jmt-type-keyword); (but faced rather as a type by Java Mode)
("for" . jmt-principal-keyword); Of a statement.
("new" . jmt-expression-keyword)
("protected" . jmt-qualifier-keyword)
("super" . jmt-expression-keyword)
("synchronized" . jmt-keyword-face-sync); (q.v.)
("this" . jmt-expression-keyword)
("throw" . jmt-principal-keyword); Of a statement.
("throws" . jmt-qualifier-keyword)
("try" . jmt-principal-keyword); Of a statement.
;;; ("void" . jmt-type-keyword); (but faced rather as a type by Java Mode)
("while" . jmt-principal-keyword); Of a statement.
;; Rare; typically once per buffer, if at all
;; ────
;;; ("_" . jmt-misused-keyword); (reserved, yet unfaced by Java Mode)
;;; ("byte" . jmt-type-keyword); (but faced rather as a type by Java Mode)
("const" . jmt-qualifier-keyword); (but reserved)
("enum" . jmt-principal-keyword); Of a type declaration.
("do" . jmt-principal-keyword); Of a statement.
;;; ("double" . jmt-type-keyword); (but faced rather as a type by Java Mode)
("extends" . jmt-qualifier-keyword)
("finally" . jmt-principal-keyword); Of a statement clause.
("goto" . jmt-principal-keyword); Of a statement (but reserved)
("implements" . jmt-qualifier-keyword)
("instanceof" . jmt-expression-keyword)
("interface" . jmt-principal-keyword); Of a type declaration.
("native" . jmt-qualifier-keyword)
("package" . jmt-boilerplate-keyword)
("record" . jmt-principal-keyword); Of a type declaration.
;;; ("short" . jmt-type-keyword); (but faced rather as a type by Java Mode)
("strictfp" . jmt-qualifier-keyword)
("switch" . jmt-principal-keyword); Of a statement.
("transient" . jmt-qualifier-keyword)
("volatile" . jmt-qualifier-keyword))
"An alist relating Java keywords to their proper facing.
The car of each entry is a Java keyword (string), while the cdr is either
its proper face (symbol) or a function in the form of `jmt-keyword-face-class'
that gives a face symbol. The list excludes the keywords that Java Mode
does not face with `font-lock-keyword-face'.")
(defun jmt-keyword-face-class (beg _end)
"The face (symbol) proper to a \\=`class\\=` keyword.
The keyword extends from buffer position BEG (number, inclusive)
to _END (exclusive). Point is left indeterminate."
(goto-char beg)
(forward-comment most-negative-fixnum); [←CW]
(if (eq ?. (char-before)); [NCE]
'jmt-expression-keyword
;;; https://docs.oracle.com/javase/specs/jls/se15/html/jls-15.html#jls-ClassLiteral
'jmt-principal-keyword)); Of a type declaration.
(defun jmt-keyword-face-default (_beg end)
"The face (symbol) proper to a \\=`default\\=` keyword.
The keyword extends from buffer position _BEG (number, inclusive)
to END (exclusive). Point is left indeterminate."
(goto-char end)
(forward-comment most-positive-fixnum); [CW→]
(let ((c (char-after)))
(if (or (eq ?: c) (eq ?- c)); [NCE]
'jmt-principal-keyword; Of a `switch` statement clause.
;;; https://docs.oracle.com/javase/specs/jls/se15/html/jls-14.html#jls-14.11
'jmt-qualifier-keyword))); Of an interface method declaration.
(defun jmt-keyword-face-static (beg end)
"The face (symbol) proper to a \\=`static\\=` keyword.
The keyword extends from buffer position BEG (number, inclusive)
to END (exclusive). Point is left indeterminate."
(goto-char beg)
(forward-comment most-negative-fixnum); [←CW]
(setq end (point)); The presumed end of the preceding keyword.
(if (and (< (skip-chars-backward jmt-name-character-set) 0)
(string= "import" (buffer-substring-no-properties (point) end)))
'jmt-boilerplate-keyword; In a static import declaration. [SI]
'jmt-qualifier-keyword)); Elsewhere.
(defun jmt-keyword-face-sync (_beg end)
"The face (symbol) proper to a \\=`synchronized\\=` keyword.
The keyword extends from buffer position _BEG (number, inclusive)
to END (exclusive). Point is left indeterminate."
(goto-char end)
(forward-comment most-positive-fixnum); [CW→]
(if (eq ?\( (char-after)); [NCE]
'jmt-principal-keyword; Of a statement.
;;; https://docs.oracle.com/javase/specs/jls/se15/html/jls-14.html#jls-14.19
'jmt-qualifier-keyword))
(defvar jmt--late-initialization-was-begun nil)
;; jmt-make-Javadoc-tag-facing (defined above in § Preliminary declarations)
(cl-assert (fboundp 'jmt-make-Javadoc-tag-facing))
(defun jmt-message (format-string &rest arguments)
"Call ``message' FORMAT-STRING ARGUMENTS` without translating embedded quotes.
Any quote characters \\=`\\=`\\=` or \\=`\\='\\=` in the FORMAT-STRING are output as is."
(message "%s" (apply #'format format-string arguments)))
;; jmt-name-character-set (defined above in § Preliminary declarations)
(cl-assert (boundp 'jmt-name-character-set))
(defface jmt-named-literal; [MDF, RF]
`((t . (:inherit font-lock-constant-face)))
"The face for literal of type boolean or null; namely \\=`true\\=`, \\=`false\\=` or \\=`null\\=`.
It inherits from `font-lock-constant-face'; customize it to distinguish named
literals from other constructs that use `font-lock-constant-face', or to subdue
the facing if you prefer to have these literals not stand out."
:group 'jmt)
(defun jmt-new-fontifiers-2 ()
"Build a `font-lock-keywords' list for fast, untamed highlighting.
See also `java-font-lock-keywords-1', which is for minimal untamed highlighting."
(java-font-lock-keywords-2)); [L2U]
(defun jmt-new-fontifiers-3 ()
"Build a `font-lock-keywords' list for accurate, tamed highlighting."
(defvar jmt-specific-fontifiers-3); [FV]
(nconc
;; Underlying Java Mode fontifiers, lightly modified
;; ───────────────────────────────
(let* ((kk (java-font-lock-keywords-3)); List of Java Mode’s fontifiers.
was-found-annotation; Whether the annotation fontifier of was found in `kk`.
(k kk); Current fontifier element of `kk`.
k-last); Previous fontifier element.
(while; Searching the list, fontifier by fontifier.
(progn
(if (equal (car k) '(eval list "\\<\\(@[a-zA-Z0-9]+\\)\\>" 1 c-annotation-face))
;; Dud fontifier: works under Java Mode, fails under JMT Mode unless
;; changed in two places `"\\_<\\(@[a-zA-Z0-9]+\\)\\>" 1 c-annotation-face t`.
(progn; 1 ↑ 2 ↑
;; Moreover its pattern does not cover the complete, valid form of annotation.
;; Therefore `jmt-new-fontifiers-3` adds a more general, replacement fontifier.
(setq was-found-annotation t)
(setcdr k-last (cdr k))); Deleting this one here in case somehow it starts working
(setq k-last k ; and interferes with the replacement.
k (cdr k)))
(and (not was-found-annotation) k)))
(unless was-found-annotation
(jmt-message "(jmt-mode): Failed to remove unwanted Java Mode fontifier: `%s` = nil"
(symbol-name 'was-found-annotation)))
kk)
;; Overlying fontifiers to tame them
;; ────────────────────
jmt-specific-fontifiers-3))
(defvar jmt-p); [GVF]
(defface jmt-package-name; [MDF, RF]
`((t . (:inherit font-lock-constant-face)))
"The face for each segment of a package name in a type reference.
It inherits from `font-lock-constant-face'; customize it to distinguish
package names from other constructs that use `font-lock-constant-face'."
:group 'jmt)
(defface jmt-package-name-declared; [MDF, RF]
`((t . (:inherit jmt-package-name)))
"The face for each segment of a package name in a package declaration.
Customize it to better distinguish between a package name appearing
in that context versus one appearing in a type reference."
:group 'jmt)
(defface jmt-param-tag-parameter `((t . (:inherit jmt-block-tag-parameter)))
"The face for the parameter-name parameter of a Javadoc `param` tag.
An exception applies to type parameters; for those, see instead
`jmt-type-variable-tag-parameter'."
:group 'javadoc-faces)
(defun jmt--patch (source source-name-base function-symbol patch-function)
"Apply a source-based monkey patch to function FUNCTION-SYMBOL.
You must call \\=`jmt--patch\\=` from a temporary buffer syntactically equivalent
to a buffer in Emacs Lisp mode. It monkey-patches the function denoted
by FUNCTION-SYMBOL, originally defined in file SOURCE (with SOURCE-NAME-BASE
as its `file-name-base'). For this, it uses the named PATCH-FUNCTION,
which must give t on success and nil on failure."; [ELM]
(condition-case x
(progn
;; Verify assumptions
;; ──────────────────
(unless (functionp function-symbol)
(signal 'jmt-x `("No such function loaded" ,function-symbol)))
(let ((load-file (symbol-file function-symbol)))
(unless (string= (file-name-base load-file) source-name-base)
(signal 'jmt-x `("Function loaded from file of base name contradictory to source file"
,function-symbol ,load-file ,source))))
(let ((function-name (symbol-name function-symbol))
beg function-name-beg function-name-end patched-function-name patched-function-symbol)
;; Restrict the temporary buffer to the function definition alone
;; ─────────────────────────────
(goto-char (point-min))
(unless (re-search-forward
(concat "^(defun[[:space:]\n]+\\(" function-name "\\)[[:space:]\n]*(") nil t)
(signal 'jmt-x `("Function definition not found in source file" ,source ,function-symbol)))
(setq beg (match-beginning 0)
function-name-beg (match-beginning 1)
function-name-end (match-end 1))
(narrow-to-region beg (scan-lists beg 1 0))
;; Patch the function definition
;; ─────────────────────────────
(goto-char beg)
(unless (funcall patch-function)
(signal 'jmt-x `("Patch failed to apply" ,function-symbol)))
;; Load the patched function under a new name
;; ─────────────────────────
(setq patched-function-name (concat "jmt-advice/" function-name))
(delete-region function-name-beg function-name-end)
(goto-char function-name-beg)
(insert patched-function-name)
(eval-buffer)
;; Remove the buffer restriction
;; ─────────────────────────────
;;; (delete-region beg (point-max)); Removing the definition, in hope it speeds later patching.
;;;;;; The deletion time is too likely to exceed the time saved.
(widen); Undoing the `narrow-to-region` above.
;; Replicate the compilation state of the original function
;; ───────────────────────────────
(setq patched-function-symbol (intern-soft patched-function-name))
(cl-assert patched-function-symbol); Avoiding a silent failure.
(when (byte-code-function-p (symbol-function function-symbol))
(run-with-idle-timer; Compile during idle time. This might improve package load times,
1.3 nil ; though early tests (with a single patch) showed no such effect.
(lambda ()
(unless (byte-compile patched-function-symbol)
(jmt-message
"(jmt-mode): Patched function `%s` is running uncompiled" function-name)))))
;; Replace the original function with the patched version
;; ──────────────────────────────────────────────────────
(advice-add function-symbol :override patched-function-symbol)))
;; Recover from failure, if any
;; ────────────────────
(jmt-x
(widen); Undoing any `narrow-to-region` still in effect above.
(delay-warning 'jmt-mode (error-message-string x) :error)))); [DW]
(defun jmt-preceding->-marks-generic-return-type ()
"Tell whether the \\=`>\\=` before point might terminate a generic return type.
Point is left indeterminate."
(when
(condition-case nil
(progn (forward-sexp -1) t); Move backward to the front of the leading delimiter.
(scan-error nil))
(forward-comment most-negative-fixnum); [←CW]
(not (eq (char-before) ?.)))); [NCE]
;;; Here a `.` would indicate a call to the method, as opposed to its declaration.
(defvar jmt--present-fontification-beg 0)
(defvar jmt--present-fontification-end 0); Non-zero only when Font Lock is fontifying via
;;; the global `font-lock-fontify-region-function`.
(defface jmt-principal-keyword; [MDF, RF]
`((t . (:inherit font-lock-keyword-face)))
"The face for the principal keyword of a declaration, statement or clause.
Cf. `jmt-qualifier-keyword'. See also subfaces
`jmt-boilerplate-keyword' and `jmt-expression-keyword'."
:group 'keyword-faces)
(defvar jmt-q); [GVF]
(defface jmt-qualifier-keyword; [MDF, RF]
`((t . (:inherit font-lock-keyword-face)))
"The face for a secondary keyword in a declaration.
Cf. `jmt-principal-keyword'."
:group 'keyword-faces)
(defface jmt-round-bracket `((t . (:inherit jmt-bracket)))
"The face for a round bracket, \\=`(\\=` or \\=`)\\=`."
:group 'delimiter-faces)
(defface jmt-separator `((t . (:inherit jmt-delimiter)))
"The face for a comma \\=`,\\=` semicolon \\=`;\\=` colon \\=`:\\=` or dot \\=`.\\=` separator."
:group 'delimiter-faces)
(defun jmt-set-for-buffer (variable value)
"Set buffer-local VARIABLE (a symbol) to VALUE.
Signal an error if the binding is not actually buffer-local.
This might happen, for example, if an externally defined VARIABLE
that was documented as being buffer-local no longer is."
(set variable value)
(cl-assert (local-variable-p variable)))
(defface jmt-shebang `((t . (:inherit font-lock-comment-delimiter-face)))
"The face for a shebang \\=`#!\\=`."
:group 'shebang-faces)
(defface jmt-shebang-body `((t . (:inherit font-lock-comment-face)))
"The face for the body of a shebang line.
The body excludes the shebang itself and any trailing comment."
:group 'shebang-faces)
(defface jmt-shebang-comment `((t . (:inherit font-lock-comment-face)))
"The face for the body of a trailing comment in a shebang line.
Such a comment may appear in case of an \\=`env\\=` interpreter."
:group 'shebang-faces
:link '(url-link "https://www.gnu.org/software/coreutils/manual/html_node/env-invocation.html"))
(defface jmt-shebang-comment-delimiter
`((t . (:inherit font-lock-comment-delimiter-face)))
"The face for the delimiter \\=`\\c\\=` of a trailing comment in a shebang line.
Such a comment may appear in case of an \\=`env\\=` interpreter."
:group 'shebang-faces
:link '(url-link "https://www.gnu.org/software/coreutils/manual/html_node/env-invocation.html"))
(defconst jmt-specific-fontifiers-3
(list
;; ══════════
;; Annotation [A, T↓]
;; ══════════
(list; Fontify each instance of annotation, overriding any misfontification of Java Mode.
(lambda (limit)
(catch 'to-fontify
(let ((m1-beg (point)); Presumed start of leading annotation mark `@`.
(m1-beg-limit (1- limit)); Room for two characters, the minimal length.
eol face m1-end m2-beg m2-end m3-beg m3-end m4-beg m4-end m5-beg m5-end)
(while (< m1-beg m1-beg-limit)
(setq m1-end (1+ m1-beg))
(if (/= ?@ (char-after m1-beg))
(setq m1-beg m1-end)
(goto-char m1-end)
(catch 'is-annotation
(when (eolp) (throw 'is-annotation nil)); [SL]
(while; Capture as group 2 the simple annotation name.
(progn
(skip-syntax-forward "-" limit); Though unconventional, whitespace is allowed
;;; between `@` and name. Nevertheless this fontifier excludes newlines; also
;;; commentary, which would be perverse here, not worth coding for. [AST, SL]
(setq m2-beg (point))
(skip-chars-forward jmt-name-character-set limit)
(setq m2-end (point))
(unless (< m2-beg m2-end) (throw 'is-annotation nil))
(setq face (get-text-property m2-beg 'face))
(if (eq face 'font-lock-constant-face); [P↓] Then the (mis)captured name should
(progn; be dot terminated, so forming a segment of a package name. [PPN]
(skip-syntax-forward "-" limit); [SL]
(unless (eq ?. (char-after)); [NCE]
(throw 'is-annotation nil))
(forward-char); Past the `.`.
t); Continuing the loop, so skipping past this segment of the name.
(unless (or (null face); The most common case. Else a misfontification:
(eq face 'font-lock-function-name-face); This one occurs in the case,
;;; for instance, of an empty `()` annotation qualifier.
(jmt-is-Java-Mode-type-face face)); [T↓]
(throw 'is-annotation nil))
nil))); Quitting the loop, having matched the simple annotation name.
(skip-syntax-forward "-" limit); [SL]
(when (eq ?\( (char-after)); [NCE]
(setq m3-beg (point); Start of trailing qualifier, it would be.
eol (line-end-position))
(condition-case nil
(progn
(forward-list 1)
(setq m5-end (point))); End of qualifier. Point now stays here.
(scan-error
(setq m5-end (point-max)))); Forcing the qualifier to be ignored below.
(if (> m5-end eol); The qualifier crosses lines, or a `scan-error` occured above.
(goto-char m2-end); Ignoring it. [SL]
;; Qualified
;; ─────────
(setq m3-end (1+ m3-beg); `(`
m4-beg m3-end
m5-beg (1- m5-end); `)`
m4-end m5-beg)
(set-match-data (list m1-beg m5-end m1-beg m1-end m2-beg m2-end m3-beg m3-end
m4-beg m4-end m5-beg m5-end (current-buffer)))
(goto-char m5-end)
(throw 'to-fontify t))); With point (still) at `m5-end` as Font Lock stipulates.
;; Unqualified
;; ───────────
(set-match-data (list m1-beg m2-end m1-beg m1-end m2-beg m2-end (current-buffer)))
(goto-char m2-end)
(throw 'to-fontify t))
(setq m1-beg (point)))))
nil))
'(1 'jmt-annotation-mark t) '(2 'c-annotation-face t) '(3 'jmt-annotation-delimiter t t)
'(4 'jmt-annotation-qualifier nil t) '(5 'jmt-annotation-delimiter t t))
;; ═══════
;; Keyword [K, T↓]
;; ═══════
(cons; Reface each Java keyword as defined in `jmt-keyword-face-alist`.
(let (match-beg match-end)
(lambda (limit)
(setq match-beg (point)); Presumptively.
(catch 'to-reface
(while (< match-beg limit)
(setq match-end (next-single-property-change match-beg 'face (current-buffer) limit))
(when (eq 'font-lock-keyword-face (get-text-property match-beg 'face))
(setq jmt-f (jmt-keyword-face
(buffer-substring-no-properties match-beg match-end) match-beg match-end))
(set-match-data (list match-beg (goto-char match-end) (current-buffer)))
(throw 'to-reface t))
(setq match-beg match-end))
nil)))
'(0 jmt-f t))
(cons; Fontify each `assert` and `record` keyword that was misfaced by Java Mode, or left unfaced.
(let (f match-beg)
(lambda (limit)
(catch 'to-reface
(while (re-search-forward "\\_<\\(?:assert\\|record\\)\\_>" limit t)
(setq match-beg (match-beginning 0)
f (get-text-property match-beg 'face))
(when (or (null f) (jmt-is-Java-Mode-type-face f)); [T↓]
;;; Misfacing as a type name has been seen for both `assert` and `record` keywords.
;;; For an instance of `assert` misfacing, see `assert stators.getClass()`. [AM]
;;; [https://github.com/Michael-Allan/waymaker/blob/3eaa6fc9f8c4137bdb463616dd3e45f340e1d34e/waymaker/gen/KittedPolyStatorSR.java#L58]
;;; More commonly the `assert` keyword is left unfaced, but no instance of this
;;; has been seen in the case of the `record` keyword.
(setq jmt-f (jmt-keyword-face (match-string-no-properties 0) match-beg (match-end 0)))
(throw 'to-reface t)))
nil)))