From: David Edmondson <dme@dme.org>
To: notmuch@notmuchmail.org
Subject: [PATCH] emacs: Add more functions to clean up text/plain parts
Date: Mon, 26 Apr 2010 14:45:30 +0100
Message-Id: <1272289530-12593-1-git-send-email-dme@dme.org>
In-Reply-To: <87tyr0hohn.fsf@yoom.home.cworth.org>
References: <87tyr0hohn.fsf@yoom.home.cworth.org>
Precedence: list

Add:
- notmuch-wash-wrap-long-lines: Wrap lines longer than the width of
  the current window whilst maintaining any citation prefix.
- notmuch-wash-tidy-citations: Tidy up citations by:
  - compress repeated otherwise blank citation lines,
  - remove otherwise blank citation lines at the head and tail of a
    citation,
- notmuch-wash-elide-blank-lines: Compress repeated blank lines and
  remove leading and trailing blank lines.

None of these is enabled by default - add them to
`notmuch-show-insert-text/plain-hook' to use.
---

Another attempt :-)

- Functions renamed to be clearer about what they do,
- Function documentation both more concise (for display in customisation
  buffers) and more complete,
- Interaction of long line wrapping and `word-wrap' improved,
- Push `notmuch-show-pretty-hook' functions that everyone will use
  directly into the code, thus avoiding the naming dilemma.

 emacs/Makefile.local  |    3 +-
 emacs/coolj.el        |  145 +++++++++++++++++++++++++++++++++++++++++++++++++
 emacs/notmuch-show.el |   28 +++++++---
 emacs/notmuch-wash.el |   84 ++++++++++++++++++++++++++++-
 4 files changed, 248 insertions(+), 12 deletions(-)
 create mode 100644 emacs/coolj.el

diff --git a/emacs/Makefile.local b/emacs/Makefile.local
index 7537c3d..ce37ca2 100644
--- a/emacs/Makefile.local
+++ b/emacs/Makefile.local
@@ -9,7 +9,8 @@ emacs_sources := \
 	$(dir)/notmuch-wash.el \
 	$(dir)/notmuch-hello.el \
 	$(dir)/notmuch-mua.el \
-	$(dir)/notmuch-address.el
+	$(dir)/notmuch-address.el \
+	$(dir)/coolj.el
 
 emacs_images := \
 	$(dir)/notmuch-logo.png
diff --git a/emacs/coolj.el b/emacs/coolj.el
new file mode 100644
index 0000000..60af60a
--- /dev/null
+++ b/emacs/coolj.el
@@ -0,0 +1,145 @@
+;;; coolj.el --- automatically wrap long lines  -*- coding:utf-8 -*-
+
+;; Copyright (C) 2000, 2001, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Authors:    Kai Grossjohann <Kai.Grossjohann@CS.Uni-Dortmund.DE>
+;;             Alex Schroeder <alex@gnu.org>
+;;             Chong Yidong <cyd@stupidchicken.com>
+;; Maintainer: David Edmondson <dme@dme.org>
+;; Keywords: convenience, wp
+
+;; This file is not part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; This is a simple derivative of some functionality from
+;;; `longlines.el'. The key difference is that this version will
+;;; insert a prefix at the head of each wrapped line. The prefix is
+;;; calculated from the originating long line.
+
+;;; No minor-mode is provided, the caller is expected to call
+;;; `coolj-wrap-region' to wrap the region of interest.
+
+;;; Code:
+
+(defgroup coolj nil
+  "Wrapping of long lines with prefix."
+  :group 'fill)
+
+(defcustom coolj-wrap-follows-window-size t
+  "Non-nil means wrap text to the window size.
+Otherwise respect `fill-column'."
+  :group 'coolj
+  :type 'boolean)
+
+(defcustom coolj-line-prefix-regexp "^\\(>+ \\)*"
+  "Regular expression that matches line prefixes."
+  :group 'coolj
+  :type 'regexp)
+
+(defvar coolj-wrap-point nil)
+
+(make-variable-buffer-local 'coolj-wrap-point)
+
+(defun coolj-determine-prefix ()
+  "Determine the prefix for the current line."
+  (save-excursion
+    (beginning-of-line)
+    (if (re-search-forward coolj-line-prefix-regexp nil t)
+	(buffer-substring (match-beginning 0) (match-end 0))
+      "")))
+
+(defun coolj-wrap-buffer ()
+  "Wrap the current buffer."
+  (coolj-wrap-region (point-min) (point-max)))
+
+(defun coolj-wrap-region (beg end)
+  "Wrap each successive line, starting with the line before BEG.
+Stop when we reach lines after END that don't need wrapping, or the
+end of the buffer."
+  (setq fill-column (if coolj-wrap-follows-window-size
+			(window-width)
+		      fill-column))
+  (let ((mod (buffer-modified-p)))
+    (setq coolj-wrap-point (point))
+    (goto-char beg)
+    (forward-line -1)
+    ;; Two successful coolj-wrap-line's in a row mean successive
+    ;; lines don't need wrapping.
+    (while (null (and (coolj-wrap-line)
+		      (or (eobp)
+			  (and (>= (point) end)
+			       (coolj-wrap-line))))))
+    (goto-char coolj-wrap-point)
+    (set-buffer-modified-p mod)))
+
+(defun coolj-wrap-line ()
+  "If the current line needs to be wrapped, wrap it and return nil.
+If wrapping is performed, point remains on the line.  If the line does
+not need to be wrapped, move point to the next line and return t."
+  (let ((prefix (coolj-determine-prefix)))
+    (if (coolj-set-breakpoint prefix)
+	(progn
+	  (insert-before-markers ?\n)
+	  (backward-char 1)
+	  (delete-char -1)
+	  (forward-char 1)
+	  (insert-before-markers prefix)
+	  nil)
+      (forward-line 1)
+      t)))
+
+(defun coolj-set-breakpoint (prefix)
+  "Place point where we should break the current line, and return t.
+If the line should not be broken, return nil; point remains on the
+line."
+  (move-to-column fill-column)
+  (if (and (re-search-forward "[^ ]" (line-end-position) 1)
+           (> (current-column) fill-column))
+      ;; This line is too long.  Can we break it?
+      (or (coolj-find-break-backward prefix)
+          (progn (move-to-column fill-column)
+                 (coolj-find-break-forward)))))
+
+(defun coolj-find-break-backward (prefix)
+  "Move point backward to the first available breakpoint and return t.
+If no breakpoint is found, return nil."
+  (let ((end-of-prefix (+ (line-beginning-position) (length prefix))))
+    (and (search-backward " " end-of-prefix 1)
+	 (save-excursion
+	   (skip-chars-backward " " end-of-prefix)
+	   (null (bolp)))
+	 (progn (forward-char 1)
+		(if (and fill-nobreak-predicate
+			 (run-hook-with-args-until-success
+			  'fill-nobreak-predicate))
+		    (progn (skip-chars-backward " " end-of-prefix)
+			   (coolj-find-break-backward prefix))
+		  t)))))
+
+(defun coolj-find-break-forward ()
+  "Move point forward to the first available breakpoint and return t.
+If no break point is found, return nil."
+  (and (search-forward " " (line-end-position) 1)
+       (progn (skip-chars-forward " " (line-end-position))
+              (null (eolp)))
+       (if (and fill-nobreak-predicate
+                (run-hook-with-args-until-success
+                 'fill-nobreak-predicate))
+           (coolj-find-break-forward)
+         t)))
+
+(provide 'coolj)
diff --git a/emacs/notmuch-show.el b/emacs/notmuch-show.el
index f9d6c93..f5de8ae 100644
--- a/emacs/notmuch-show.el
+++ b/emacs/notmuch-show.el
@@ -62,16 +62,19 @@ any given message."
   "A list of functions called to decorate the headers listed in
 `notmuch-message-headers'.")
 
-(defvar notmuch-show-hook '(notmuch-show-pretty-hook)
-  "A list of functions called after populating a
-`notmuch-show' buffer.")
-
-(defvar notmuch-show-insert-text/plain-hook '(notmuch-wash-text/plain-citations)
-  "A list of functions called to clean up text/plain body parts.")
+(defcustom notmuch-show-hook nil
+  "Functions called after populating a `notmuch-show' buffer."
+  :group 'notmuch
+  :type 'hook)
 
-(defun notmuch-show-pretty-hook ()
-  (goto-address-mode 1)
-  (visual-line-mode))
+(defcustom notmuch-show-insert-text/plain-hook '(notmuch-wash-excerpt-citations)
+  "Functions used to improve the display of text/plain parts."
+  :group 'notmuch
+  :type 'hook
+  :options '(notmuch-wash-wrap-long-lines
+	     notmuch-wash-tidy-citations
+	     notmuch-wash-elide-blank-lines
+	     notmuch-wash-excerpt-citations))
 
 (defmacro with-current-notmuch-show-message (&rest body)
   "Evaluate body with current buffer set to the text of current message"
@@ -511,6 +514,13 @@ function is used. "
 		   query-context)
 	  (notmuch-show-insert-forest
 	   (notmuch-query-get-threads basic-args))))
+
+      ;; Enable buttonisation of URLs and email addresses in the
+      ;; buffer.
+      (goto-address-mode t)
+      ;; Act on visual lines rather than logical lines.
+      (visual-line-mode t)
+
       (run-hooks 'notmuch-show-hook))
 
     ;; Move straight to the first open message
diff --git a/emacs/notmuch-wash.el b/emacs/notmuch-wash.el
index 5ca567f..57f0cc5 100644
--- a/emacs/notmuch-wash.el
+++ b/emacs/notmuch-wash.el
@@ -1,6 +1,7 @@
 ;; notmuch-wash.el --- cleaning up message bodies
 ;;
 ;; Copyright © Carl Worth
+;; Copyright © David Edmondson
 ;;
 ;; This file is part of Notmuch.
 ;;
@@ -18,6 +19,11 @@
 ;; along with Notmuch.  If not, see <http://www.gnu.org/licenses/>.
 ;;
 ;; Authors: Carl Worth <cworth@cworth.org>
+;;          David Edmondson <dme@dme.org>
+
+(require 'coolj)
+
+;;
 
 (defvar notmuch-wash-signature-regexp
   "^\\(-- ?\\|_+\\)$"
@@ -108,8 +114,8 @@ is what to put on the button."
 		     'invisibility-spec invis-spec
 		     :type button-type))))
 
-(defun notmuch-wash-text/plain-citations (depth)
-  "Markup citations, and up to one signature in the buffer."
+(defun notmuch-wash-excerpt-citations (depth)
+  "Excerpt citations and up to one signature."
   (goto-char (point-min))
   (beginning-of-line)
   (while (and (< (point) (point-max))
@@ -151,4 +157,78 @@ is what to put on the button."
 
 ;;
 
+(defun notmuch-wash-elide-blank-lines (depth)
+  "Elide leading, trailing and successive blank lines."
+
+  ;; Algorithm derived from `article-strip-multiple-blank-lines' in
+  ;; `gnus-art.el'.
+
+  ;; Make all blank lines empty.
+  (goto-char (point-min))
+  (while (re-search-forward "^[[:space:]\t]+$" nil t)
+    (replace-match "" nil t))
+
+  ;; Replace multiple empty lines with a single empty line.
+  (goto-char (point-min))
+  (while (re-search-forward "^\n\\(\n+\\)" nil t)
+    (delete-region (match-beginning 1) (match-end 1)))
+
+  ;; Remove a leading blank line.
+  (goto-char (point-min))
+  (if (looking-at "\n")
+      (delete-region (match-beginning 0) (match-end 0)))
+
+  ;; Remove a trailing blank line.
+  (goto-char (point-max))
+  (if (looking-at "\n")
+      (delete-region (match-beginning 0) (match-end 0))))
+
+;;
+
+(defun notmuch-wash-tidy-citations (depth)
+  "Improve the display of cited regions of a message.
+
+Perform four transformations on the message body:
+
+- Remove lines of repeated citation leaders with no other
+  content,
+- Remove citation leaders standing alone before a block of cited
+  text,
+- Remove citation trailers standing alone after a block of cited
+  text."
+
+  ;; Remove lines of repeated citation leaders with no other content.
+  (goto-char (point-min))
+  (while (re-search-forward "\\(^>[> ]*\n\\)\\{2,\\}" nil t)
+    (replace-match "\\1"))
+
+  ;; Remove citation leaders standing alone before a block of cited
+  ;; text.
+  (goto-char (point-min))
+  (while (re-search-forward "\\(\n\\|^[^>].*\\)\n\\(^>[> ]*\n\\)" nil t)
+    (replace-match "\\1\n"))
+
+  ;; Remove citation trailers standing alone after a block of cited
+  ;; text.
+  (goto-char (point-min))
+  (while (re-search-forward "\\(^>[> ]*\n\\)\\(^$\\|^[^>].*\\)" nil t)
+    (replace-match "\\2")))
+
+;;
+
+(defun notmuch-wash-wrap-long-lines (depth)
+  "Wrap any long lines in the message to the width of the window.
+
+When doing so, maintaining citation leaders in the wrapped text."
+
+  (let ((coolj-wrap-follows-window-size nil)
+	(fill-column (- (window-width)
+			depth
+			;; 2 to avoid poor interaction with
+			;; `word-wrap'.
+			2)))
+    (coolj-wrap-region (point-min) (point-max))))
+
+;;
+
 (provide 'notmuch-wash)
-- 
1.7.0