git.shemshak.org - ~bandali/configs/blob - .emacs.d/lisp/gnus-article-treat-patch.el

   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)
  59 which are used to determine the highlighting of pseudo headers in
  60 the commit message (such as \"Signed-off-by:\").
  61
  62 The first face if used to highlight the header's name; the second
  63 highlights 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
  79 is."
  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
 160 treatment; `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
 172 diff; `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
 187 values will be matched as regular expressions within the currently
 188 processed part.  Non-string value are supposed to be code fragments,
 189 which determine whether or not to do treatment: The code needs to
 190 return `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
 194 patch 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
 210 if it looks patch-like.
 211
 212 The 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
 363 they *are* patches - or possibly, when you take git's format-patch output,
 364 entire commit exports - including comments).  This treatment assumes the
 365 use of unified diffs.  Here is how it works:
 366
 367 The 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
 435 And that's it.
 436
 437 You may define the look of several things: pseudo headers, scissor
 438 lines, three-dashes-line, equals lines, diffstat lines, diffstat
 439 summary. Then there is added lines, removed lines, context lines,
 440 diff-header lines and diff-file-header lines, for which we are
 441 borrowing 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)