;;; liece-hilit.el --- coloring IRC buffers
;; Copyright (C) 1998-2000 Daiki Ueno

;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1998-09-28
;; Revised: 1998-11-25
;; Keywords: IRC, liece

;; This file is part of Liece.

;; 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.


;;; Commentary:
;; 

;;; Code:

(require 'invisible)

(eval-when-compile
  (require 'liece-inlines)
  (require 'font-lock))

(autoload 'liece-url-add-buttons "liece-url")
(autoload 'liece-channel-add-buttons "liece-channel")
(autoload 'liece-nick-add-buttons "liece-nick")

(defgroup liece-highlight nil
  "Highlight your IRC buffer"
  :tag "Highlight"
  :prefix "liece-"
  :group 'liece)

(defgroup liece-highlight-faces nil
  "Faces for highlight your IRC buffer"
  :tag "Faces"
  :prefix "liece-highlight-"
  :group 'liece-highlight)

(defcustom liece-change-face 'liece-change-face
  "Face used for displaying \"*** Change:\" line."
  :type 'face
  :group 'liece-highlight-faces)

(defcustom liece-notice-face 'liece-notice-face
  "Face used for displaying \"*** Notice:\" line."
  :type 'face
  :group 'liece-highlight-faces)

(defcustom liece-broadcast-face 'liece-broadcast-face
  "Face used for displaying \"*** Broadcast:\" line."
  :type 'face
  :group 'liece-highlight-faces)

(defcustom liece-wallops-face 'liece-wallops-face
  "Face used for displaying \"*** Wallops:\" line."
  :type 'face
  :group 'liece-highlight-faces)
  
(defcustom liece-error-face 'liece-error-face
  "Face used for displaying \"*** Error:\" line."
  :type 'face
  :group 'liece-highlight-faces)

(defcustom liece-info-face 'liece-info-face
  "Face used for displaying \"*** Info:\" line."
  :type 'face
  :group 'liece-highlight-faces)

(defcustom liece-timestamp-face 'liece-timestamp-face
  "Face used for displaying \"*** Time:\" line."
  :type 'face
  :group 'liece-highlight-faces)

(defcustom liece-client-face 'liece-client-face
  "Face used for displaying \"CLIENT@\" line."
  :type 'face
  :group 'liece-highlight-faces)

(defcustom liece-dcc-face 'liece-dcc-face
  "Face used for displaying \"*** DCC:\" line."
  :type 'face
  :group 'liece-highlight-faces)

(defcustom liece-prefix-face 'liece-prefix-face
  "Face used for displaying \"<nick>\" extent."
  :type 'face
  :group 'liece-highlight-faces)

(defcustom liece-priv-prefix-face 'liece-priv-prefix-face
  "Face used for displaying \"=nick\" line."
  :type 'face
  :group 'liece-highlight-faces)

(defcustom liece-pattern-face 'liece-pattern-face
  "Face used for displaying user defined pattern."
  :type 'face
  :group 'liece-highlight-faces)

(defcustom liece-quoted-bold-face 'liece-quoted-bold-face
  "Face used for displaying \002 quoted string."
  :type 'face
  :group 'liece-highlight-faces)

(defcustom liece-quoted-inverse-face 'liece-quoted-inverse-face
  "Face used for displaying \026 quoted string."
  :type 'face
  :group 'liece-highlight-faces)

(defcustom liece-quoted-underline-face 'liece-quoted-underline-face
  "Face used for displaying \037 quoted string."
  :type 'face
  :group 'liece-highlight-faces)

(defcustom liece-quoted-colors-ircle
  '("white" "black" "red" "orange" "yellow" "LightGreen" "DarkOliveGreen"
    "cyan4" "turquoise" "blue" "black" "black" "black" "black" "black"
    "DarkBlue" "purple1" "purple2" "purple3" "magenta")
  "Color list for displaying \003 quoted string."
  :type '(list (radio string face))
  :group 'liece-highlight)

(defcustom liece-quoted-colors-mirc
  '("white" "black" "blue" "DarkOliveGreen" "red" "brown" "purple"
    "orange" "yellow" "green" "cyan4" "turquoise" "RoyalBlue" "HotPink"
    "gray50" "gray75" "black" "black" "black" "black")
  "Color list for displaying \013 quoted string."
  :type '(list (radio string face))
  :group 'liece-highlight)
  
(defcustom liece-highlight-jingle-function nil
  "Function playing jingles."
  :type 'function
  :group 'liece-highlight)

(defface liece-change-face
  '((((class color)
      (background dark))
     (:foreground "cyan" :bold t))
    (((class color)
      (background light))
     (:foreground "RoyalBlue" :bold t))
    (t
     (:bold t)))
  "Face used for displaying \"*** Change:\" line"
  :group 'liece-highlight-faces)

(defface liece-notice-face
  '((((class color)
      (background dark))
     (:foreground "green2" :bold t))
    (((class color)
      (background light))
     (:foreground "MidnightBlue" :bold t))
    (t
     (:bold t)))
  "Face used for displaying \"*** Notice:\" line"
  :group 'liece-highlight-faces)

(defface liece-broadcast-face
  '((((class color)
      (background dark))
     (:foreground "Plum1" :italic t))
    (((class color)
      (background light))
     (:foreground "purple" :italic t))
    (t
     (:italic t)))
  "Face used for displaying \"*** Broadcast:\" line"
  :group 'liece-highlight-faces)

(defface liece-wallops-face
  '((((class color)
      (background dark))
     (:foreground "yellow" :bold t))
    (((class color)
      (background light))
     (:foreground "blue4" :bold t))
    (t
     (:bold t)))
  "Face used for displaying \"*** Wallops:\" line"
  :group 'liece-highlight-faces)

(defface liece-error-face
  '((((class color)
      (background dark))
     (:foreground "cornflower blue" :bold t))
    (((class color)
      (background light))
     (:foreground "DarkGreen"))
    (t
     (:bold t)))
  "Face used for displaying \"*** Error:\" line"
  :group 'liece-highlight-faces)

(defface liece-info-face
  '((((class color)
      (background dark))
     (:foreground "PaleTurquoise" :bold t))
    (((class color)
      (background light))
     (:foreground "RoyalBlue"))
    (t
     (:bold t)))
  "Face used for displaying \"*** Info:\" line"
  :group 'liece-highlight-faces)

(defface liece-timestamp-face
  '((((class color)
      (background dark))
     (:foreground "yellow" :bold t))
    (((class color)
      (background light))
     (:foreground "blue4" :bold t))
    (t
     (:bold t)))
  "Face used for displaying \"*** Time:\" line"
  :group 'liece-highlight-faces)

(defface liece-client-face
  '((((class color)
      (background dark))
     (:foreground "orange"))
    (((class color)
      (background light))
     (:foreground "red"))
    (t
     (:bold nil)))
  "Face used for displaying \"CLIENT@\" line"
  :group 'liece-highlight-faces)

(defface liece-dcc-face
  '((((class color)
      (background dark))
     (:foreground "orange"))
    (((class color)
      (background light))
     (:foreground "red"))
    (t
     (:bold nil)))
  "Face used for displaying \"*** DCC:\" line"
  :group 'liece-highlight-faces)

(defface liece-prefix-face
  '((((class color)
      (background dark))
     (:foreground "moccasin"))
    (((class color)
      (background light))
     (:foreground "firebrick"))
    (t
     (:bold nil)))
  "Face used for displaying \"<nick>\" extent"
  :group 'liece-highlight-faces)

(defface liece-priv-prefix-face
  '((((class color)
      (background dark))
     (:foreground "orange"))
    (((class color)
      (background light))
     (:foreground "grey40"))
    (t
     (:bold nil)))
  "Face used for displaying \"=nick\" line"
  :group 'liece-highlight-faces)

(defface liece-pattern-face
  '((((class color)
      (background dark))
     (:foreground "red"))
    (((class color)
      (background light))
     (:foreground "red"))
    (t
     (:bold nil)))
  "Face used for displaying user defined pattern"
  :group 'liece-highlight-faces)

(defface liece-quoted-bold-face
  '((t (:bold t)))
  "Face used for displaying \002 quoted string"
  :group 'liece-highlight-faces)

(defface liece-quoted-inverse-face
  '((t (:inverse-video t)))
  "Face used for displaying \026 quoted string"
  :group 'liece-highlight-faces)

(defface liece-quoted-underline-face
  '((t (:underline t)))
  "Face used for displaying \037 quoted string"
  :group 'liece-highlight-faces)

(defcustom liece-highlight-font-lock-keywords
  (append
   ;; setting property occurred once
   (list
    `(,(concat
	"^\\(" liece-time-prefix-regexp "\\)?"
	"\\(\\([][<>(-][][<>(-]?[^ <>)]*[][<>)-][][<>)-]?\\)\\|"
	"\\(=[^ ]*=\\|\\*\\*[^ \*]*\\*\\*\\)\\) ")
      (3 liece-prefix-face append t)
      (4 liece-priv-prefix-face append t)
      ("\\(\002\\)\\([^\002\026\037\003]*\\)" nil nil
       (2 liece-quoted-bold-face t t))
      ("\\(\026\\)\\([^\002\026\037\003]*\\)" nil nil
       (2 liece-quoted-inverse-face t t))
      ("\\(\037\\)\\([^\002\026\037\003]*\\)" nil nil
       (2 liece-quoted-underline-face t t))))
   ;; set property whole line
   (mapcar
    (lambda (line)
      (cons
       (concat
	"^\\(" liece-time-prefix-regexp "\\)?\\("
	(regexp-quote
	 (symbol-value (intern (format "liece-%s-prefix" line))))
	".*\\)$")
       (list 2 (intern (format "liece-%s-face" line)) t t)))
    '(change notice broadcast wallops error info timestamp client dcc))
   '((eval . (cons liece-highlight-pattern liece-pattern-face))))
  "Normal and deformed faces for IRC normal line."
  :type '(repeat (list string))
  :group 'liece-highlight)

(put 'liece-channel-mode 'font-lock-defaults
     '(liece-highlight-font-lock-keywords t))
(put 'liece-others-mode 'font-lock-defaults
     '(liece-highlight-font-lock-keywords t))
(put 'liece-dialogue-mode 'font-lock-defaults
     '(liece-highlight-font-lock-keywords t))

;;; This is a kludge for fontifying buffer whose name starts with a space.
;;; Font-lock isn't responsible for (maybe) invisible buffers.
(defadvice font-lock-mode
  (around liece-replace-space-in-buffer-name activate)
  (if (char-equal (aref (buffer-name) 0) ? )
      (unwind-protect
	  (progn
	    (aset (buffer-name) 0 ?_)
	    ad-do-it)
	(aset (buffer-name) 0 ? ))
    ad-do-it))

(add-hook 'liece-after-load-startup-hook
	  'liece-highlight-maybe-turn-on-font-lock)

(defun liece-highlight-maybe-turn-on-font-lock ()
  (when liece-highlight-mode
    (add-hook 'liece-channel-mode-hook
	      'liece-highlight-turn-on-font-lock)
    (add-hook 'liece-others-mode-hook
	      'liece-highlight-turn-on-font-lock)
    (add-hook 'liece-dialogue-mode-hook
	      'liece-highlight-turn-on-font-lock)
    (add-hook 'liece-after-insert-functions 'liece-url-add-buttons)
    (add-hook 'liece-after-insert-functions 'liece-channel-add-buttons)
    ;;(add-hook 'liece-after-insert-functions 'liece-nick-add-buttons)
    ))

(defun liece-highlight-turn-on-font-lock ()
  (make-local-variable 'font-lock-defaults)
  (setq font-lock-defaults '(liece-highlight-font-lock-keywords t))
  (make-local-variable 'font-lock-verbose)
  (setq font-lock-verbose nil)
  (make-local-variable 'font-lock-support-mode)
  (setq font-lock-support-mode nil)
  (make-local-hook 'font-lock-mode-hook)
  (setq font-lock-mode-hook nil)
  (turn-on-font-lock)
  (make-local-hook 'after-change-functions)
  (or liece-display-prefix-tag
      (add-hook 'after-change-functions
		'liece-highlight-maybe-hide-prefix nil 'local))
  (add-hook 'after-change-functions
	    'liece-highlight-colorize-quote nil 'local)
  (add-hook 'after-change-functions
	    'liece-highlight-maybe-hide-quote 'append 'local)
  (when (and (eq major-mode 'liece-dialogue-mode)
	     (liece-functionp liece-highlight-jingle-function))
    (add-hook 'after-change-functions
	      'liece-highlight-maybe-play-jingle 'append 'local)))

(defun liece-highlight-maybe-hide-prefix (st nd len)
  (save-excursion
    (goto-char st)
    (if (looking-at liece-generic-prefix-tag-regexp)
	(invisible-region
	 (match-beginning 1) (match-end 1)))))

(defun liece-highlight-maybe-hide-quote (st nd len)
  (save-excursion
    (goto-char st)
    (while (re-search-forward "[\002\026\037]\\|[\003\013][0-9:;<=]+" nd t)
      (invisible-region
       (match-beginning 0) (match-end 0)))))

(defun liece-highlight-maybe-play-jingle (st nd len)
  (save-excursion
    (goto-char st)
    (when (re-search-forward
	   (if (listp liece-highlight-pattern)
	       (car liece-highlight-pattern)
	     liece-highlight-pattern)
	   nd t)
      (funcall liece-highlight-jingle-function))))

(defun liece-highlight-colorize-quote (st nd len)
  (save-excursion
    (goto-char st)
    (let (num face faces vender name ovl)
      (while (re-search-forward "\\([\003\013][0-9:;<=]+\\)\\([^\002\026\037\003\013]*\\)" nd t)
	(setq ovl (make-overlay (match-beginning 2) (match-end 2))
	      num (match-string 1)
	      vender (cond ((eq ?\003 (aref num 0)) 'ircle)
			   ((eq ?\013 (aref num 0)) 'mirc))
	      num (if (< 57 (char-int (aref num 1)))
		      (- (char-int (aref num 1)) 43)
		    (string-to-int (substring num 1)))
	      faces (nthcdr num (symbol-value
				 (intern (format "liece-quoted-colors-%s"
						 vender))))
	      face (car faces))
	(when (stringp face)
	  (setq face (make-face (intern (format "liece-quoted-color-%s-%d"
						vender num))))
	  (set-face-foreground face (car faces))
	  (setcar faces face))
	(overlay-put ovl 'face face)))))

(provide 'liece-hilit)

;;; liece-hilit.el ends here