Assimilate alloy-mode 0d05bdd
[~bandali/configs] / lisp / gnus-article-treat-patch.el
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 ;;
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)