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