git.shemshak.org - ~bandali/configs/blob - 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)