;; emchat-emphasis.el --- Gnus-style text emphasis in EMchat

;; Copyright (C) 2005 - 2011 Steve Youngs

;; Author:        Steve Youngs <steve@emchat.org>
;; Maintainer:    Steve Youngs <steve@emchat.org>
;; Created:       <2005-04-29>
;; Homepage:      http://www.emchat.org/
;; Keywords:      ICQ

;; This file is part of EMchat.

;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;;
;; 3. Neither the name of the author nor the names of any contributors
;;    may be used to endorse or promote products derived from this
;;    software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;; DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; Commentary:
;;
;;   "prettify" the log buffer, ala Gnus.  Most of this is unashamedly
;;   stolen from Gnus.

;;; Todo:
;;
;;

;;; Code:
(eval-when-compile
  (autoload 'manual-entry "man" nil t))

(defmacro emchat-emphasis-custom-with-format (&rest body)
  `(let ((format "\
\\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\
\\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)"))
     ,@body))

(defun emchat-emphasis-custom-value-to-external (value)
  (emchat-emphasis-custom-with-format
   (if (consp (car value))
       (list (format format (car (car value)) (cdr (car value)))
	     2
	     (if (nth 1 value) 2 3)
	     (nth 2 value))
     value)))

(defun emchat-emphasis-custom-value-to-internal (value)
  (emchat-emphasis-custom-with-format
   (let ((regexp (concat "\\`"
			 (format (regexp-quote format)
				 "\\([^()]+\\)" "\\([^()]+\\)")
			 "\\'"))
	 pattern)
     (if (string-match regexp (setq pattern (car value)))
	 (list (cons (match-string 1 pattern) (match-string 2 pattern))
	       (= (nth 2 value) 2)
	       (nth 3 value))
       value))))

(defgroup emchat-emphasis nil
  "Emphasise text in the log buffer."
  :prefix "emchat-emphasis-"
  :group 'emchat-log)

(defcustom emchat-emphasis-enabled-flag nil
  "*When non-nil, emphasise text in the log buffer."
  :type 'boolean
  :group 'emchat-emphasis)

(defcustom emchat-emphasis-alist
  (let ((types
	 '(("\\*" "\\*" bold)
	   ("_" "_" underline)
	   ("/" "/" italic)
	   ("_/" "/_" underline-italic)
	   ("_\\*" "\\*_" underline-bold)
	   ("\\*/" "/\\*" bold-italic)
	   ("_\\*/" "/\\*_" underline-bold-italic))))
    (nconc
     (emchat-emphasis-custom-with-format
      (mapcar (lambda (spec)
		(list (format format (car spec) (cadr spec))
		      (or (nth 3 spec) 2)
		      (or (nth 4 spec) 3)
		      (intern (format "emchat-emphasis-%s" (nth 2 spec)))))
	      types))
     '(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
	2 3 emchat-emphasis-underline))))
  "*Alist that says how to fontify certain phrases.
Each item looks like this:

  (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline)

The first element is a regular expression to be matched.  The second
is a number that says what regular expression grouping used to find
the entire emphasised word.  The third is a number that says what
regexp grouping should be displayed and highlighted.  The fourth
is the face used for highlighting."
  :type
  '(repeat
    (menu-choice
     :format "%[Customizing Style%]\n%v"
     :indent 2
     (group :tag "Default"
	    :value ("" 0 0 default)
	    :value-create
	    (lambda (widget)
	      (let ((value (widget-get
			    (cadr (widget-get (widget-get widget :parent)
					      :args))
			    :value)))
		(if (not (eq (nth 2 value) 'default))
		    (widget-put
		     widget
		     :value
		     (emchat-emphasis-custom-value-to-external value))))
	      (widget-group-value-create widget))
	    regexp
	    (integer :format "Match group: %v")
	    (integer :format "Emphasise group: %v")
	    face)
     (group :tag "Simple"
	    :value (("_" . "_") nil default)
	    (cons :format "%v"
		  (regexp :format "Start regexp: %v")
		  (regexp :format "End regexp: %v"))
	    (boolean :format "Show start and end patterns: %[%v%]\n"
		     :on " On " :off " Off ")
	    face)))
  :get #'(lambda (symbol)
	   (mapcar #'emchat-emphasis-custom-value-to-internal
		   (default-value symbol)))
  :set #'(lambda (symbol value)
	   (set-default symbol (mapcar #'emchat-emphasis-custom-value-to-external
				       value)))
  :group 'emchat-emphasis)

(defcustom emchat-emphasise-whitespace-regexp "^[ \t]+\\|[ \t]*\n"
  "A regexp to describe whitespace which should not be emphasised.
Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\".
The former avoids underlining of leading and trailing whitespace,
and the latter avoids underlining any whitespace at all."
  :group 'emchat-emphasis
  :type 'regexp)

(defcustom emchat-emphasis-url-regexp
  (concat "\\(https?://\\|s?ftp://\\|gopher://\\|telnet://"
	  "\\|wais://\\|file:/\\|s?news:\\)"
	  "[^]\t\n \"'()<>[^`{}]*[^]\t\n \"'()<>[^`{}.,;]+")
  "A regular expression matching URLs."
  :type 'regexp
  :group 'emchat-emphasis)

(defcustom emchat-emphasis-email-regexp
  "[-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+"
  "A regular expression matching email addresses."
  :type 'regexp
  :group 'emchat-emphasis)

(defcustom emchat-emphasis-man-regexp "\\b\\w+([1-9n])"
  "A regular expression matching unix manual pages.

For example, `xemacs\(1\)'."
  :type 'regexp
  :group 'emchat-emphasis)

(make-face 'emchat-emphasis-bold)
(set-face-parent 'emchat-emphasis-bold 'bold)

(defcustom emchat-emphasis-bold 'emchat-emphasis-bold
  "Face used for displaying strong emphasised text (*word*)."
  :type 'face
  :group 'emchat-emphasis)

(make-face 'emchat-emphasis-italic)
(set-face-parent 'emchat-emphasis-italic 'italic)

(defcustom emchat-emphasis-italic 'emchat-emphasis-italic
  "Face used for displaying italic emphasised text (/word/)."
  :type 'face
  :group 'emchat-emphasis)

(make-face 'emchat-emphasis-underline)
(set-face-parent 'emchat-emphasis-underline 'underline)

(defcustom emchat-emphasis-underline 'emchat-emphasis-underline
  "Face used for displaying underlined emphasised text (_word_)."
  :type 'face
  :group 'emchat-emphasis)

(make-face 'emchat-emphasis-underline-bold)
(set-face-parent 'emchat-emphasis-underline-bold 'bold)
(set-face-property 'emchat-emphasis-underline-bold 'underline t)

(defcustom emchat-emphasis-underline-bold 'emchat-emphasis-underline-bold
  "Face used for displaying underlined bold emphasised text (_*word*_)."
  :type 'face
  :group 'emchat-emphasis)

(make-face 'emchat-emphasis-underline-italic)
(set-face-parent 'emchat-emphasis-underline-italic 'italic)
(set-face-property 'emchat-emphasis-underline-italic 'underline t)

(defcustom emchat-emphasis-underline-italic 'emchat-emphasis-underline-italic
  "Face used for displaying underlined italic emphasised text (_/word/_)."
  :type 'face
  :group 'emchat-emphasis)

(make-face 'emchat-emphasis-bold-italic)
(set-face-parent 'emchat-emphasis-bold-italic 'bold-italic)

(defcustom emchat-emphasis-bold-italic 'emchat-emphasis-bold-italic
  "Face used for displaying bold italic emphasised text (/*word*/)."
  :type 'face
  :group 'emchat-emphasis)

(make-face 'emchat-emphasis-underline-bold-italic)
(set-face-parent 'emchat-emphasis-underline-bold-italic 'bold-italic)
(set-face-property 'emchat-emphasis-underline-bold-italic 'underline t)

(defcustom emchat-emphasis-underline-bold-italic
  'emchat-emphasis-underline-bold-italic
  "Face used for displaying underlined bold italic emphasised text.
Example: (_/*word*/_)."
  :type 'face
  :group 'emchat-emphasis)

(make-face 'emchat-emphasis-strikethru)
(set-face-property 'emchat-emphasis-strikethru 'strikethru t)

(defcustom emchat-emphasis-strikethru 'emchat-emphasis-strikethru
  "Face used for displaying strike-through text (-word-)."
  :type 'face
  :group 'emchat-emphasis)

(defface emchat-emphasis-highlight-words
  '((t (:background "black" :foreground "yellow")))
  "Face used for displaying highlighted words."
  :group 'emchat-emphasis)

;;; Internal variables

(defun emchat-emphasis-treat-message (b e)
  "Emphasise text in region B E according to `emchat-emphasis-alist'."
  (let ((alist emchat-emphasis-alist)
	regexp elem beg invisible visible face)
    (save-excursion
      (save-restriction
	(narrow-to-region b e)
	(goto-char (point-min))
	(setq beg (point))
	(while (setq elem (pop alist))
	  (goto-char beg)
	  (setq regexp (car elem)
		invisible (nth 1 elem)
		visible (nth 2 elem)
		face (nth 3 elem))
	  (while (re-search-forward regexp nil t)
	    (when (and (match-beginning visible) (match-beginning invisible))
	      (put-text-property
	       (match-beginning invisible) (match-end invisible) 'invisible t)
	      (remove-text-properties
	       (match-beginning visible) (match-end visible) '(invisible t))
	      (put-text-property
	       (match-beginning visible) (match-end visible) 'face face)
	      (goto-char (match-end invisible)))))))))

(defun emchat-emphasis-visit-hyperlink-at-point ()
  "Follow the hyperlink at point in the EMchat log buffer.

This can either be a URL, in which case `browse-url' is called with
the string of the extent as an arg.  Or it can be an email address, in
which case `compose-mail' is called.  Or it can be a Unix manual page,
where `manual-entry' is called."
  (interactive)
  (when (extentp (extent-at (point)))
    (let ((str (extent-string (extent-at (point)))))
      (cond ((string-match emchat-emphasis-url-regexp str)
	     (browse-url str))
	    ((string-match emchat-emphasis-email-regexp str)
	     (compose-mail str))
	    ((string-match emchat-emphasis-man-regexp str)
	     (if (fboundp 'manual-entry)
		 (manual-entry str)
	       (error 'unimplemented "Unix manual pages")))
	    (t
	     (error 'invalid-operation))))))

(defun emchat-emphasis-visit-hyperlink-at-mouse (event)
  "Follow the hyperlink at EVENT in the EMchat log buffer.

This can either be a URL, in which case `browse-url' is called with
the string of the extent as an arg.  Or it can be an email address, in
which case `compose-mail' is called.  Or it can be a Unix manual page,
where `manual-entry' is called."
  (interactive "e")
  (when (extentp (extent-at-event event))
    (let ((str (extent-string (extent-at-event event))))
      (cond ((string-match emchat-emphasis-url-regexp str)
	     (browse-url str))
	    ((string-match emchat-emphasis-email-regexp str)
	     (compose-mail str))
	    ((string-match emchat-emphasis-man-regexp str)
	     (if (fboundp 'manual-entry)
		 (manual-entry str)
	       (error 'unimplemented "Unix manual pages")))
	    (t
	     (error 'invalid-operation))))))

(defun emchat-emphasis-hyperlink-message (b e)
  "Add hyperlinks to the message in region B E.

In other words, URLs, email addresses, and unix manual page names will
be \"clickable\"."
  (save-excursion
    (save-restriction
      (narrow-to-region b e)
      (goto-char (point-min))
      (while (re-search-forward emchat-emphasis-url-regexp nil t)
	(let ((extent (make-extent (match-beginning 0) (match-end 0)))
	      (echo "Mouse button2 -- Follow this link."))
	  (set-extent-property extent 'face 'widget-button-face)
	  (set-extent-property extent 'mouse-face 'highlight)
	  (set-extent-property extent 'keymap emchat-hyperlink-map)
	  (set-extent-property extent 'help-echo echo)
	  (set-extent-property extent 'balloon-help echo)
	  (set-extent-property extent 'duplicable t)))
      (while (re-search-forward emchat-emphasis-email-regexp nil t)
	(let ((extent (make-extent (match-beginning 0) (match-end 0)))
	      (echo "Mouse button2 -- Compose mail."))
	  (set-extent-property extent 'face 'emchat-emphasis-highlight-words)
	  (set-extent-property extent 'mouse-face 'highlight)
	  (set-extent-property extent 'keymap emchat-hyperlink-map)
	  (set-extent-property extent 'help-echo echo)
	  (set-extent-property extent 'balloon-help echo)
	  (set-extent-property extent 'duplicable t)))
      (while (re-search-forward emchat-emphasis-man-regexp nil t)
	(let ((extent (make-extent (match-beginning 0) (match-end 0)))
	      (echo "Mouse button2 -- Read this manual."))
	  (set-extent-property extent 'face 'man-xref)
	  (set-extent-property extent 'mouse-face 'highlight)
	  (set-extent-property extent 'keymap emchat-hyperlink-map)
	  (set-extent-property extent 'help-echo echo)
	  (set-extent-property extent 'balloon-help echo)
	  (set-extent-property extent 'duplicable t))))))

(provide 'emchat-emphasis)
;;; emchat-emphasis.el ends here