;;; header-narrowing.el -- Narrowing mail headers
;; Copyright (C) 2003 Hideyuki Shirai <shirai@meadowy.org>

;; Author: Hideyuki Shirai <shirai@meadowy.org>
;;         Yuuichi Teranishi <teranisi@gohome.org>
;; Keywords: Mail

;; This program 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 2, or (at your option)
;; any later version.

;; This program 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 this program; if not, you can either send email to this
;; program's maintainer or write to: The Free Software Foundation,
;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.

;;; Commentary:
;;

;;; Code:
(defvar header-narrowing-lines 4)
(defvar header-narrowing-header-end
  "^\\(----\\|--text follows this line--\\|\\)$")
(defvar header-narrowing-fields '("to" "cc"))
(defvar header-narrowing-string " ...")

(defface header-narrowing-face
  '((((class color) (background light))
     (:foreground "black" :background "dark khaki"))
    (((class color) (background dark))
     (:foreground "white" :background "dark goldenrod"))
    (t (:bold t)))
  "*header narrowing face."
  :group 'mail)

(defun header-narrowing ()
  "Narrowing headers."
  (save-excursion
    (save-restriction
      (goto-char (point-min))
      (if (re-search-forward header-narrowing-header-end
			     nil t)
	  (beginning-of-line)
	(goto-char (point-max)))
      (narrow-to-region (point-min) (point))
      (let ((fields header-narrowing-fields))
	(while fields
	  (header-narrowing-1 (concat "^" (car fields) ":"))
	  (setq fields (cdr fields)))))))

(defvar header-narrowing-map (make-sparse-keymap))
(define-key header-narrowing-map [mouse-2] 'header-narrowing-again-at-mouse)

(defvar header-narrowing-widen-map (make-sparse-keymap))
(define-key header-narrowing-widen-map [mouse-2]
  'header-narrowing-widen-at-mouse)

(defun header-narrowing-again-at-mouse (event)
  (interactive "e")
  (save-window-excursion
    (save-excursion
      (mouse-set-point event)
      (header-narrowing))))

(defun header-narrowing-1 (hregexp)
  (let ((case-fold-search t)
	ov start end)
    (goto-char (point-min))
    (while (re-search-forward hregexp nil t)
      (setq start (match-beginning 0))
      (forward-line 1)
      (setq end (progn (while (looking-at "^[ \t]") (forward-line))
		       (forward-line -1)
		       (line-end-position)))
      (if (<= (count-lines start end) header-narrowing-lines)
	  (forward-line 1)
	(goto-char start)
	(forward-line (1- header-narrowing-lines))
	(end-of-line)
	(setq start (point))
	(unless (eq (get-char-property start 'invisible) 'header-narrowing)
	  (setq ov (or
		    (let ((ovs (overlays-at start))
			  ov)
		      (while (and ovs (not (overlayp ov)))
			(if (overlay-get (car ovs) 'header-narrowing)
			    (setq ov (car ovs)))
			(setq ovs (cdr ovs)))
		      ov)
		    (make-overlay start end)))
	  (overlay-put ov 'header-narrowing t)
	  (overlay-put ov 'evaporate t)
	  (overlay-put ov 'invisible 'header-narrowing)
	  (overlay-put ov 'after-string header-narrowing-string))))))

(defun header-narrowing-widen-at-mouse (event)
  (interactive "e")
  (save-selected-window
    (select-window (posn-window (event-start event)))
    (let* ((win (selected-window))
	   (wpos (window-start win))
	   (pos (posn-point (event-start event)))
	   (ovs (overlays-in (1- pos) (1+ pos)))	;; Uum...
	   ov)
      (while (and ovs (not (overlayp ov)))
	(when (overlay-get (car ovs) 'header-narrowing)
	  (setq ov (car ovs)))
	(setq ovs (cdr ovs)))
      (when (overlayp ov)
	(overlay-put ov 'face 'header-narrowing-face)
	(overlay-put ov 'local-map header-narrowing-map)
	(overlay-put ov 'invisible nil)
	(overlay-put ov 'after-string nil))
      (set-window-start win wpos))))

(defun header-narrowing-setup ()
  (when (boundp 'line-move-ignore-invisible)
    (set (make-local-variable 'line-move-ignore-invisible) t))
  (set-text-properties 0 (length header-narrowing-string)
		       `(face
			 header-narrowing-face
			 keymap
			 ,header-narrowing-widen-map)
		       header-narrowing-string))

(defun header-narrowing-toggle ()
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (if (re-search-forward header-narrowing-header-end nil t)
	(beginning-of-line)
      (goto-char (point-max)))
    (let ((ovs (overlays-in (point-min) (point)))
	  ov hn-ovs)
      (while (setq ov (car ovs))
	(when (overlay-get ov 'header-narrowing)
	  (setq hn-ovs (cons ov hn-ovs)))
	(setq ovs (cdr ovs)))
      (if hn-ovs
	  (while hn-ovs
	    (delete-overlay (car hn-ovs))
	    (setq hn-ovs (cdr hn-ovs)))
	(header-narrowing)))))

;; MUA specific
(defun wl-message-header-narrowing ()
  (unless (eq this-command 'wl-summary-redisplay-all-header)
    (header-narrowing)))

(defun wl-summary-header-narrowing-toggle ()
  (interactive)
  (save-selected-window
    (let* ((mbuf wl-message-buffer)
	   (mwin (when mbuf (get-buffer-window mbuf)))
	   (wpos (when mwin (window-start mwin))))
      (when mbuf
	(set-buffer mbuf)
	(header-narrowing-toggle)
	(and wpos (set-window-start mwin wpos))))))

(add-hook 'wl-message-buffer-created-hook 'header-narrowing-setup)
(add-hook 'wl-message-redisplay-hook 'wl-message-header-narrowing)
(add-hook 'wl-summary-mode-hook
	  (lambda ()
	    (define-key wl-summary-mode-map "\C-c\C-f"
	      'wl-summary-header-narrowing-toggle)))

(defun mew-message-header-narrowing ()
  (unless (and (eq this-command 'mew-summary-display)
	       current-prefix-arg)
    (header-narrowing)))

(defun mew-summary-header-narrowing-toggle ()
  (interactive)
  (save-selected-window
    (let* ((mbuf (mew-buffer-message))
	   (mwin (when mbuf (get-buffer-window mbuf)))
	   (wpos (when mwin (window-start mwin))))
      (when mbuf
	(set-buffer mbuf)
	(header-narrowing-toggle)
	(and wpos (set-window-start mwin wpos))))))

(add-hook 'mew-message-mode-hook 'header-narrowing-setup)
(add-hook 'mew-message-hook 'mew-message-header-narrowing)
(add-hook 'mew-summary-mode-hook
	  (lambda ()
	    (define-key mew-summary-mode-map "zh"
	      'mew-summary-header-narrowing-toggle)))

(provide 'header-narrowing)

;;; header-narrowing.el ends here