;;; emh-face.el --- header highlighting in emh.

;; Copyright (C) 1997 MORIOKA Tomohiko

;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
;; Created: 1997/3/4
;; Version: $Id: emh-face.el,v 0.5 1997-09-25 15:11:34 morioka Exp $
;; Keywords: header, highlighting

;; This file is part of emh.

;; 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Code:

(require 'emu)

(defsubst emh-set-face-foreground (face color)
  (condition-case err
      (set-face-foreground face color)
    (error (message "Color `%s' is not found." color))
    ))

(defsubst emh-make-face-bold (face)
  (set-face-font face (face-font 'bold))
  )

(defsubst emh-make-face-italic (face)
  (set-face-font face (face-font 'italic))
  )

(or (find-face 'from-field-body)
    (progn
      (make-face 'from-field-body)
      (emh-set-face-foreground 'from-field-body "dark slate blue")
      (emh-make-face-bold 'from-field-body)
      ))

(or (find-face 'subject-field-body)
    (progn
      (make-face 'subject-field-body)
      (emh-set-face-foreground 'subject-field-body "violet red")
      (emh-make-face-bold 'subject-field-body)
      ))

(or (find-face 'to-field-body)
    (progn
      (make-face 'to-field-body)
      (emh-set-face-foreground 'to-field-body "red")
      (emh-make-face-bold 'to-field-body)
      ))

(or (find-face 'cc-field-body)
    (progn
      (make-face 'cc-field-body)
      (emh-set-face-foreground 'cc-field-body "salmon")
      (emh-make-face-bold 'cc-field-body)
      ))

(or (find-face 'reply-to-field-body)
    (progn
      (make-face 'reply-to-field-body)
      (emh-set-face-foreground 'reply-to-field-body "salmon")
      (emh-make-face-bold 'reply-to-field-body)
      ))

(or (find-face '-to-field-body)
    (progn
      (make-face '-to-field-body)
      (emh-set-face-foreground '-to-field-body "red")
      ))

(or (find-face 'date-field-body)
    (progn
      (make-face 'date-field-body)
      (emh-set-face-foreground 'date-field-body "blue violet")
      (emh-make-face-bold 'date-field-body)
      ))

(or (find-face 'message-id-field-body)
    (progn
      (make-face 'message-id-field-body)
      (emh-set-face-foreground 'message-id-field-body "royal blue")
      (emh-make-face-bold 'message-id-field-body)
      ))

(or (find-face 'field-body)
    (progn
      (make-face 'field-body)
      (emh-set-face-foreground 'field-body "dark green")
      (emh-make-face-italic 'field-body)
      ))

(or (find-face 'field-name)
    (progn
      (make-face 'field-name)
      (emh-set-face-foreground 'field-name "dark green")
      (emh-make-face-bold 'field-name)
      ))

(defvar emh-header-face
  '(("^From:"		field-name	from-field-body)
    ("^Subject:"	field-name	subject-field-body)
    ("^To:"		field-name	to-field-body)
    ("^cc:"		field-name	cc-field-body)
    ("^Reply-To:"	field-name	reply-to-field-body)
    ("^.+-To:"		field-name	-to-field-body)
    ("^Date:"		field-name	date-field-body)
    ("^Message-Id:"	field-name	message-id-field-body)
    (t			field-name	field-body)
    ))

(defun emh-highlight-header ()
  (goto-char (point-min))
  (while (looking-at "^[^:]+:")
    (let* ((beg (match-beginning 0))
	   (med (match-end 0))
	   (end (std11-field-end))
	   (field-name (buffer-substring beg med))
	   (rule (catch 'found
		   (let ((rest emh-header-face))
		     (while rest
		       (let* ((rule (car rest))
			      (key (car rule)))
			 (if (and (stringp key)
				  (string-match key field-name))
			     (throw 'found (cdr rule))
			   ))
		       (setq rest (cdr rest))
		       )
		     (cdr (assq t emh-header-face))
		     )))
	   )
      (overlay-put (make-overlay beg med) 'face (car rule))
      (overlay-put (make-overlay med end) 'face (cadr rule))
      )
    (forward-char)
    ))


;;; @ end
;;;

(provide 'emh-face)

;;; emh-face.el ends here