Commit | Line | Data |
---|---|---|
b2ca8283 AB |
1 | ;;; gnus-article-treat-patch.el --- Highlight inline patches in articles |
2 | ;; | |
3 | ;; Copyright © 2011-2019 Frank Terbeck <ft@bewatermyfriend.org> | |
4 | ;; | |
5 | ;; This file is not part of GNU Emacs. | |
6 | ;; | |
7 | ;; This file is free software; you can redistribute it and/or modify it under | |
8 | ;; the terms of the GNU General Public License as published by the Free Soft- | |
9 | ;; ware Foundation; either version 3, or (at your option) any later version. | |
10 | ;; | |
11 | ;; This file is distributed in the hope that it will be useful, but WITHOUT ANY | |
12 | ;; WARRANTY without even the implied warranty of MERCHANTABILITY or FITNESS FOR | |
13 | ;; A PARTICULAR PURPOSE. See the GNU General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU General Public License along with | |
16 | ;; this file. If not, see <http://www.gnu.org/licenses/>. | |
17 | ;; | |
18 | ;; | |
19 | ;;; Commentary: | |
20 | ;; | |
a5cf4300 AB |
21 | ;; Gnus addon to beautify patch-like emails. This uses a "ft/" prefix for |
22 | ;; everything to avoid clashing with anything upstream. That prefix can be | |
23 | ;; savely s,ft/,,'d - if this is to be submitted to the gnus developers. | |
24 | ||
25 | (require 'diff-mode) | |
26 | ||
27 | (add-hook 'gnus-part-display-hook 'ft/gnus-article-treat-patch) | |
28 | ||
29 | ;; Colour handling and faces | |
30 | (defun ft/gnus-colour-line (use-face) | |
31 | "Set text overlay to `use-face' for the current line." | |
32 | (overlay-put (make-overlay (point-at-bol) (point-at-eol)) 'face use-face)) | |
33 | ||
34 | (make-face 'ft/gnus-three-dashes) | |
35 | (set-face-attribute 'ft/gnus-three-dashes nil :foreground "brightblue") | |
36 | (make-face 'ft/gnus-scissors) | |
37 | (set-face-attribute 'ft/gnus-scissors nil :foreground "brown") | |
38 | (make-face 'ft/gnus-diff-index) | |
39 | (set-face-attribute 'ft/gnus-diff-index nil :foreground "brightmagenta") | |
40 | (make-face 'ft/gnus-diff-hunk) | |
41 | (set-face-attribute 'ft/gnus-diff-hunk nil :foreground "brightblue") | |
42 | (make-face 'ft/gnus-diff-equals) | |
43 | (set-face-attribute 'ft/gnus-diff-equals nil :foreground "brightmagenta") | |
44 | (make-face 'ft/gnus-commit-message) | |
45 | (set-face-attribute 'ft/gnus-commit-message nil :foreground "white") | |
46 | (make-face 'ft/gnus-diff-stat-file) | |
47 | (set-face-attribute 'ft/gnus-diff-stat-file nil :foreground "yellow") | |
48 | (make-face 'ft/gnus-diff-stat-bar) | |
49 | (set-face-attribute 'ft/gnus-diff-stat-bar nil :foreground "magenta") | |
50 | (make-face 'ft/gnus-diff-stat-num) | |
51 | (set-face-attribute 'ft/gnus-diff-stat-num nil :foreground "white") | |
52 | (make-face 'ft/gnus-diff-misc) | |
53 | (set-face-attribute 'ft/gnus-diff-misc nil :foreground "magenta") | |
54 | (make-face 'ft/gnus-commit-comment) | |
55 | (set-face-attribute 'ft/gnus-commit-comment nil :inherit 'default) | |
56 | (make-face 'ft/gnus-diff-header) | |
57 | (set-face-attribute 'ft/gnus-diff-header nil :inherit 'diff-header) | |
58 | (make-face 'ft/gnus-diff-add) | |
59 | (set-face-attribute 'ft/gnus-diff-add nil :inherit 'diff-added) | |
60 | (make-face 'ft/gnus-diff-remove) | |
61 | (set-face-attribute 'ft/gnus-diff-remove nil :inherit 'diff-removed) | |
62 | ||
63 | ;; Pseudo-headers | |
64 | (defvar ft/gnus-article-patch-pseudo-headers | |
65 | '(("^Acked-by: " 'gnus-header-name 'gnus-header-from) | |
66 | ("^C\\(c\\|C\\): " 'gnus-header-name 'gnus-header-from) | |
67 | ("^From: " 'gnus-header-name 'gnus-header-from) | |
68 | ("^Link: " 'gnus-header-name 'gnus-header-from) | |
69 | ("^Reported-by: " 'gnus-header-name 'gnus-header-from) | |
70 | ("^Reviewed-by: " 'gnus-header-name 'gnus-header-from) | |
71 | ("^Signed-off-by: " 'gnus-header-name 'gnus-header-from) | |
72 | ("^Subject: " 'gnus-header-name 'gnus-header-from) | |
73 | ("^Suggested-by: " 'gnus-header-name 'gnus-header-from)) | |
74 | "List of lists of regular expressions (with two face names) | |
75 | which are used to determine the highlighting of pseudo headers in | |
76 | the commit message (such as \"Signed-off-by:\"). | |
77 | ||
78 | The first face if used to highlight the header's name; the second | |
79 | highlights the header's value.") | |
80 | ||
81 | (defun ft/gnus-pseudo-header-get (line) | |
82 | "Check if `line' is a pseudo header, and if so return its enty in | |
83 | `ft/gnus-article-patch-pseudo-headers'." | |
84 | (catch 'done | |
85 | (dolist (entry ft/gnus-article-patch-pseudo-headers) | |
86 | (let ((regex (car entry))) | |
87 | (if (string-match regex line) | |
88 | (throw 'done entry)))) | |
89 | (throw 'done '()))) | |
90 | ||
91 | (defun ft/gnus-pseudo-header-p (line) | |
92 | "Returns `t' if `line' looks like a pseudo-header; `nil' otherwise. | |
93 | ||
94 | `ft/gnus-article-patch-pseudo-headers' is used to determine what a pseudo-header | |
95 | is." | |
96 | (if (eq (ft/gnus-pseudo-header-get line) '()) nil t)) | |
97 | ||
98 | (defun ft/gnus-pseudo-header-colour (line) | |
99 | "Colourise a pseudo-header line." | |
100 | (let ((data (ft/gnus-pseudo-header-get line))) | |
101 | (if (eq data '()) | |
102 | nil | |
103 | (let* ((s (point-at-bol)) | |
104 | (e (point-at-eol)) | |
105 | (colon (re-search-forward ":")) | |
106 | (value (+ colon 1))) | |
107 | (overlay-put (make-overlay s colon) 'face (nth 1 data)) | |
108 | (overlay-put (make-overlay value e) 'face (nth 2 data)))))) | |
109 | ||
110 | ;; diff-stat | |
111 | (defun ft/gnus-diff-stat-colour (line) | |
112 | "Colourise a diff-stat line." | |
113 | (let ((s (point-at-bol)) | |
114 | (e (point-at-eol)) | |
115 | (bar (- (re-search-forward "|") 1)) | |
116 | (num (- (re-search-forward "[0-9]") 1)) | |
117 | (pm (- (re-search-forward "\\([+-]\\|$\\)") 1))) | |
118 | ||
119 | (overlay-put (make-overlay s (- bar 1)) 'face 'ft/gnus-diff-stat-file) | |
120 | (overlay-put (make-overlay bar (+ bar 1)) 'face 'ft/gnus-diff-stat-bar) | |
121 | (overlay-put (make-overlay num pm) 'face 'ft/gnus-diff-stat-num) | |
122 | ||
123 | (goto-char pm) | |
124 | (let* ((plus (looking-at "\\+")) | |
125 | (regex (if plus "-+" "\\++")) | |
126 | (brk (if plus | |
127 | (re-search-forward "-" e t) | |
128 | (re-search-forward "\\+" e t))) | |
129 | (first-face (if plus 'ft/gnus-diff-add 'ft/gnus-diff-remove)) | |
130 | (second-face (if plus 'ft/gnus-diff-remove 'ft/gnus-diff-add))) | |
131 | ||
132 | (if (eq brk nil) | |
133 | (overlay-put (make-overlay pm e) 'face first-face) | |
134 | (progn | |
135 | (setq brk (- brk 1)) | |
136 | (overlay-put (make-overlay pm brk) 'face first-face) | |
137 | (overlay-put (make-overlay brk e) 'face second-face)))))) | |
138 | ||
139 | (defun ft/gnus-diff-stat-summary-colour (line) | |
140 | "Colourise a diff-stat summary-line." | |
141 | (let* ((e (point-at-eol)) | |
142 | (plus (- (re-search-forward "(\\+)" e t) 2)) | |
143 | (minus (- (re-search-forward "(-)" e t) 2))) | |
144 | (overlay-put (make-overlay plus (+ plus 1)) 'face 'ft/gnus-diff-add) | |
145 | (overlay-put (make-overlay minus (+ minus 1)) 'face 'ft/gnus-diff-remove))) | |
146 | ||
147 | (defun ft/gnus-diff-stat-line-p (line) | |
148 | "Return `t' if `line' is a diff-stat line; `nil' otherwise." | |
149 | (string-match "^ *[^ ]+[^|]+| +[0-9]+\\( *\\| +[+-]+\\)$" line)) | |
150 | ||
151 | (defun ft/gnus-diff-stat-summary-p (line) | |
152 | "Return `t' if `line' is a diff-stat summary-line; `nil' otherwise." | |
153 | (string-match "^ *[0-9]+ file\\(s\\|\\) changed,.*insertion.*deletion" line)) | |
154 | ||
155 | ;; unified-diffs | |
156 | (defun ft/gnus-diff-header-p (line) | |
157 | "Returns `t' if `line' looks like a diff-header; `nil' otherwise." | |
158 | (cond | |
159 | ((string-match "^\\(\\+\\+\\+\\|---\\) " line) t) | |
160 | ((string-match "^diff -" line) t) | |
161 | (t nil))) | |
162 | ||
163 | (defun ft/gnus-index-line-p (line) | |
164 | "Returns `t' if `line' looks like an index-line; `nil' otherwise." | |
165 | (cond | |
166 | ((string-match "^Index: " line) t) | |
167 | ((string-match "^index [0-9a-f]+\\.\\.[0-9a-f]+" line) t) | |
168 | (t nil))) | |
169 | ||
170 | (defun ft/gnus-hunk-line-p (line) | |
171 | "Returns `t' if `line' looks like a hunk-line; `nil' otherwise." | |
172 | (string-match "^@@ -[0-9]+,[0-9]+ \\+[0-9]+,[0-9]+ @@" line)) | |
173 | ||
174 | (defun ft/gnus-atp-misc-diff-p (line) | |
175 | "Return `t' if `line' is a \"misc line\" with respect to patch | |
176 | treatment; `nil' otherwise." | |
177 | (let ((patterns '("^new file" | |
178 | "^RCS file:" | |
179 | "^retrieving revision "))) | |
180 | (catch 'done | |
181 | (dolist (regex patterns) | |
182 | (if (string-match regex line) | |
183 | (throw 'done t))) | |
184 | (throw 'done nil)))) | |
185 | ||
186 | (defun ft/gnus-atp-looks-like-diff (line) | |
187 | "Return `t' if `line' looks remotely like a line from a unified | |
188 | diff; `nil' otherwise." | |
189 | (or (ft/gnus-index-line-p line) | |
190 | (ft/gnus-diff-header-p line) | |
191 | (ft/gnus-hunk-line-p line))) | |
192 | ||
193 | ;; miscellaneous line handlers | |
194 | (defun ft/gnus-scissors-line-p (line) | |
195 | "Returns `t' if `line' looks like a scissors-line; `nil' otherwise." | |
196 | (cond | |
197 | ((string-match "^\\( *--* *\\(8<\\|>8\\)\\)+ *-* *$" line) t) | |
198 | (t nil))) | |
199 | ||
200 | ;; Patch mail detection | |
201 | (defvar ft/gnus-article-patch-conditions nil | |
202 | "List of conditions that will enable patch treatment. String | |
203 | values will be matched as regular expressions within the currently | |
204 | processed part. Non-string value are supposed to be code fragments, | |
205 | which determine whether or not to do treatment: The code needs to | |
206 | return `t' if treatment is wanted.") | |
207 | ||
208 | (defun ft/gnus-part-want-patch-treatment () | |
209 | "Run through `ft/gnus-article-patch-conditions' to determine whether | |
210 | patch treatment is wanted or not. Return `t' or `nil' accordingly." | |
211 | (catch 'done | |
212 | (dolist (entry ft/gnus-article-patch-conditions) | |
213 | (cond | |
214 | ((stringp entry) | |
215 | (if (re-search-forward entry nil t) | |
216 | (throw 'done t))) | |
217 | (t | |
218 | (if (eval entry) | |
219 | (throw 'done t))))) | |
220 | (throw 'done nil))) | |
221 | ||
222 | ||
223 | ;; The actual article treatment code | |
224 | (defun ft/gnus-article-treat-patch-state-machine () | |
225 | "Implement the state machine which colourises a part of an article | |
226 | if it looks patch-like. | |
227 | ||
228 | The state machine works like this: | |
229 | ||
230 | 0a. The machinery starts at the first line of the article's body. Not | |
231 | the header lines. We don't care about header lines at all. | |
232 | ||
233 | 0b. The whole thing works line by line. It doesn't do any forward or | |
234 | backward looks. | |
235 | ||
236 | 1. Initially, we assume, that what we'll see first is part of the | |
237 | patch's commit-message. Hence this first initial state is | |
238 | \"commit-message\". There are several ways out of this state: | |
239 | ||
240 | a) a scissors line is found (see 2.) | |
241 | b) a pseudo-header line is found (see 3.) | |
242 | c) a three-dashes line is found (see 4.) | |
243 | d) something that looks like the start of a unified diff is | |
244 | found (see 7.) | |
245 | ||
246 | 2. A scissors line is something that looks like a pair of scissors running | |
247 | through a piece of paper. Like this: | |
248 | ||
249 | ------ 8< ----- 8< ------ | |
250 | ||
251 | or this: | |
252 | ||
253 | ------------>8----------- | |
254 | ||
255 | The function `ft/gnus-scissors-line-p' decides whether a line is a | |
256 | scissors line or not. After a scissors line was treated, the machine | |
257 | will switch back to the \"commit-mesage\" state. | |
258 | ||
259 | 3. This is very similar to a scissors line. It'll just return to the old | |
260 | state after its being done. The `ft/gnus-pseudo-header-p' function | |
261 | decides if a line is a pseudo header. The line will be appropriately | |
262 | coloured. | |
263 | ||
264 | 4. A three-dashes line is a line that looks like this: \"---\". It's the | |
265 | definite end of the \"commit-message\" state. The three dashes line is | |
266 | coloured and the state switches to \"commit-comment\". (See 5.) | |
267 | ||
268 | 5. Nothing in \"commit-comment\" will appear in the generated commit (this | |
269 | is git-am specific semantics, but it's useful, so...). It may contain | |
270 | things like random comments or - promimently - a diff stat. (See 6.) | |
271 | ||
272 | 6. A diff stat provides statistics about how much changed in a given commit | |
273 | by files and by whole commit (in a summary line). Two functions | |
274 | `ft/gnus-diff-stat-line-p' and `ft/gnus-diff-stat-summary-p' decide if a | |
275 | line belongs to a diff stat. It's coloured appropriately and the state | |
276 | switches back to \"commit-comment\". | |
277 | ||
278 | 7. There is a function `ft/gnus-unified-diff-line-p' which will cause the | |
279 | state to switch to \"unified-diff\" state from either \"commit-message\" | |
280 | or \"commit-comment\". In this mode there can be a set of lines types: | |
281 | ||
282 | a) diff-header lines (`ft/gnus-diff-header-p') | |
283 | b) index lines (`ft/gnus-index-line-p') | |
284 | c) hunk lines (`ft/gnus-hunk-line-p') | |
285 | d) equals line (\"^==*$\") | |
286 | e) context lines (\"^ \") | |
287 | f) add lines (\"^\\+\") | |
288 | g) remove lines (\"^-\") | |
289 | h) empty lines (\"^$\") | |
290 | ||
291 | This state runs until the end of the part." | |
292 | (catch 'ft/gnus-atp-done | |
293 | (let ((state 'commit-message) | |
294 | line do-not-move) | |
295 | ||
296 | (while t | |
297 | ;; Put the current line into an easy-to-handle string variable. | |
298 | (setq line | |
299 | (buffer-substring-no-properties (point-at-bol) (point-at-eol))) | |
300 | (setq do-not-move nil) | |
301 | ||
302 | ;; Switched state machine. The "real" states are `commit-message', | |
303 | ;; `commit-comment' and `unified-diff'. The other "states" are only | |
304 | ;; single-line colourisations that return to their respective parent- | |
305 | ;; state. Each state may (throw 'ft/gnus-atp-done) to leave the state- | |
306 | ;; machine immediately. | |
307 | (setq state | |
308 | (cond | |
309 | ||
310 | ((eq state 'commit-message) | |
311 | (cond | |
312 | ((ft/gnus-scissors-line-p line) | |
313 | (ft/gnus-colour-line 'ft/gnus-scissors) | |
314 | 'commit-message) | |
315 | ((ft/gnus-pseudo-header-p line) | |
316 | (ft/gnus-pseudo-header-colour line) | |
317 | 'commit-message) | |
318 | ((string= line "---") | |
319 | (ft/gnus-colour-line 'ft/gnus-three-dashes) | |
320 | 'commit-comment) | |
321 | ((ft/gnus-atp-looks-like-diff line) | |
322 | (setq do-not-move t) | |
323 | 'unified-diff) | |
324 | (t | |
325 | (ft/gnus-colour-line 'ft/gnus-commit-message) | |
326 | 'commit-message))) | |
327 | ||
328 | ((eq state 'commit-comment) | |
329 | (cond | |
330 | ((ft/gnus-diff-stat-line-p line) | |
331 | (ft/gnus-diff-stat-colour line) | |
332 | 'commit-comment) | |
333 | ((ft/gnus-diff-stat-summary-p line) | |
334 | (ft/gnus-diff-stat-summary-colour line) | |
335 | 'commit-comment) | |
336 | ((ft/gnus-atp-looks-like-diff line) | |
337 | (setq do-not-move t) | |
338 | 'unified-diff) | |
339 | (t | |
340 | (ft/gnus-colour-line 'ft/gnus-commit-comment) | |
341 | 'commit-comment))) | |
342 | ||
343 | ((eq state 'unified-diff) | |
344 | (cond | |
345 | ((ft/gnus-diff-header-p line) | |
346 | (ft/gnus-colour-line 'ft/gnus-diff-header) | |
347 | 'unified-diff) | |
348 | ((ft/gnus-index-line-p line) | |
349 | (ft/gnus-colour-line 'ft/gnus-diff-index) | |
350 | 'unified-diff) | |
351 | ((ft/gnus-hunk-line-p line) | |
352 | (ft/gnus-colour-line 'ft/gnus-diff-hunk) | |
353 | 'unified-diff) | |
354 | ((string-match "^==*$" line) | |
355 | (ft/gnus-colour-line 'ft/gnus-diff-equals) | |
356 | 'unified-diff) | |
357 | ((string-match "^$" line) | |
358 | 'unified-diff) | |
359 | ((string-match "^ " line) | |
360 | (ft/gnus-colour-line 'ft/gnus-diff-context) | |
361 | 'unified-diff) | |
362 | ((ft/gnus-atp-misc-diff-p line) | |
363 | (ft/gnus-colour-line 'ft/gnus-diff-misc) | |
364 | 'unified-diff) | |
365 | ((string-match "^\\+" line) | |
366 | (ft/gnus-colour-line 'ft/gnus-diff-add) | |
367 | 'unified-diff) | |
368 | ((string-match "^-" line) | |
369 | (ft/gnus-colour-line 'ft/gnus-diff-remove) | |
370 | 'unified-diff) | |
371 | (t 'unified-diff))))) | |
372 | ||
373 | (if (not do-not-move) | |
374 | (if (> (forward-line) 0) | |
375 | (throw 'ft/gnus-atp-done t))))))) | |
376 | ||
377 | (defun ft/gnus-article-treat-patch () | |
378 | "Highlight mail parts, that look like patches (well, usually | |
379 | they *are* patches - or possibly, when you take git's format-patch output, | |
380 | entire commit exports - including comments). This treatment assumes the | |
381 | use of unified diffs. Here is how it works: | |
382 | ||
383 | The most fancy type of patch mails look like this: | |
384 | ||
385 | From: ... | |
386 | Subject: ... | |
387 | Other-Headers: ... | |
388 | ||
389 | Body text, which can be reflecting the commit message but may | |
390 | optionally be followed by a so called scissors line, which | |
391 | looks like this (in case of a scissors line, the text above is | |
392 | not part of the commit message): | |
393 | ||
394 | -------8<---------- | |
395 | ||
396 | If there really was a scissors line, then it's usually | |
397 | followed by repeated mail-headers. Which do not *have* to | |
398 | be the same as the one from the sender. | |
399 | ||
400 | From: ... | |
401 | Subject: ... | |
402 | ||
403 | More text. Usually part of the commit message. Likely | |
404 | multiline. What follows may be an optional diffstat. If | |
405 | there is one, it's usually preceded by a line that contains | |
406 | only three dashes and nothing more. Before the diffstat, | |
407 | however, there may be a set of pseudo headers again, like | |
408 | these: | |
409 | ||
410 | Acked-by: Mike Dev <md@other.tld> | |
411 | Signed-off-by: Joe D. User <jdu@example.com> | |
412 | ||
413 | --- | |
414 | ChangeLog | 5 ++++- | |
415 | 1 file changed, 4 insertions(+), 1 deletions(-) | |
416 | ||
417 | Now, there is again room for optional text, which is not | |
418 | part of the actual commit message. May be multiline. Actually, | |
419 | anything between the three-dashes line and the diff content | |
420 | is ignored as far as the commit message goes. | |
421 | ||
422 | Now for the actual diff part. I want this to work for as | |
423 | many unified diff formats as possible. What comes to mind | |
424 | is the format used by git and the format used by cvs and | |
425 | quilt. | |
426 | ||
427 | CVS style looks like this: | |
428 | ||
429 | Index: foo/bar.c | |
430 | ============================================================ | |
431 | --- boo.orig/foo/bar.c 2010-02-24 .... | |
432 | +++ boo/foo/bar.c 2010-02-28 .... | |
433 | @@ -1823,7 +1823,7 @@ | |
434 | <hunk> | |
435 | ||
436 | There may be multiple hunks. Each file gets an \"Index:\" and | |
437 | equals line. Now the git format looks like this: | |
438 | ||
439 | diff --git a/ChangeLog b/ChangeLog | |
440 | index 6ffbc8c..36e5c17 100644 | |
441 | --- a/ChangeLog | |
442 | +++ b/ChangeLog | |
443 | @@ -3,6 +3,9 @@ | |
444 | <hunk> | |
445 | ||
446 | Again, there may be multiple hunks. | |
447 | ||
448 | When all hunks and all files are done, there may be additional | |
449 | text below the actual text. | |
450 | ||
451 | And that's it. | |
452 | ||
453 | You may define the look of several things: pseudo headers, scissor | |
454 | lines, three-dashes-line, equals lines, diffstat lines, diffstat | |
455 | summary. Then there is added lines, removed lines, context lines, | |
456 | diff-header lines and diff-file-header lines, for which we are | |
457 | borrowing the highlighting faces for from `diff-mode'." | |
458 | (if (ft/gnus-part-want-patch-treatment) | |
459 | (save-excursion | |
460 | (progn | |
461 | (let ((inhibit-read-only t)) | |
462 | (goto-char (point-min)) | |
463 | (ft/gnus-article-treat-patch-state-machine)))))) | |
464 | ||
465 | (provide 'gnus-article-treat-patch) |