cgit.sxemacs.org Git - emchat/blob - emchat-emphasis.el

   1 ;; emchat-emphasis.el --- Gnus-style text emphasis in EMchat
   2
   3 ;; Copyright (C) 2005 - 2010 Steve Youngs
   4
   5 ;; Author:        Steve Youngs <steve@emchat.org>
   6 ;; Maintainer:    Steve Youngs <steve@emchat.org>
   7 ;; Created:       <2005-04-29>
   8 ;; Homepage:      http://www.emchat.org/
   9 ;; Keywords:      ICQ
  10
  11 ;; This file is part of EMchat.
  12
  13 ;; Redistribution and use in source and binary forms, with or without
  14 ;; modification, are permitted provided that the following conditions
  15 ;; are met:
  16 ;;
  17 ;; 1. Redistributions of source code must retain the above copyright
  18 ;;    notice, this list of conditions and the following disclaimer.
  19 ;;
  20 ;; 2. Redistributions in binary form must reproduce the above copyright
  21 ;;    notice, this list of conditions and the following disclaimer in the
  22 ;;    documentation and/or other materials provided with the distribution.
  23 ;;
  24 ;; 3. Neither the name of the author nor the names of any contributors
  25 ;;    may be used to endorse or promote products derived from this
  26 ;;    software without specific prior written permission.
  27 ;;
  28 ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
  29 ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  30 ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  31 ;; DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  32 ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  33 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  34 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
  35 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  36 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
  37 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
  38 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  39
  40 ;;; Commentary:
  41 ;;
  42 ;;   "prettify" the log buffer, ala Gnus.  Most of this is unashamedly
  43 ;;   stolen from Gnus.
  44
  45 ;;; Todo:
  46 ;;
  47 ;;
  48
  49 ;;; Code:
  50 (eval-when-compile
  51   (autoload 'manual-entry "man" nil t))
  52
  53 (defmacro emchat-emphasis-custom-with-format (&rest body)
  54   `(let ((format "\
  55 \\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\
  56 \\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)"))
  57      ,@body))
  58
  59 (defun emchat-emphasis-custom-value-to-external (value)
  60   (emchat-emphasis-custom-with-format
  61    (if (consp (car value))
  62        (list (format format (car (car value)) (cdr (car value)))
  63              2
  64              (if (nth 1 value) 2 3)
  65              (nth 2 value))
  66      value)))
  67
  68 (defun emchat-emphasis-custom-value-to-internal (value)
  69   (emchat-emphasis-custom-with-format
  70    (let ((regexp (concat "\\`"
  71                          (format (regexp-quote format)
  72                                  "\\([^()]+\\)" "\\([^()]+\\)")
  73                          "\\'"))
  74          pattern)
  75      (if (string-match regexp (setq pattern (car value)))
  76          (list (cons (match-string 1 pattern) (match-string 2 pattern))
  77                (= (nth 2 value) 2)
  78                (nth 3 value))
  79        value))))
  80
  81 (defgroup emchat-emphasis nil
  82   "Emphasise text in the log buffer."
  83   :prefix "emchat-emphasis-"
  84   :group 'emchat-log)
  85
  86 (defcustom emchat-emphasis-enabled-flag nil
  87   "*When non-nil, emphasise text in the log buffer."
  88   :type 'boolean
  89   :group 'emchat-emphasis)
  90
  91 (defcustom emchat-emphasis-alist
  92   (let ((types
  93          '(("\\*" "\\*" bold)
  94            ("_" "_" underline)
  95            ("/" "/" italic)
  96            ("_/" "/_" underline-italic)
  97            ("_\\*" "\\*_" underline-bold)
  98            ("\\*/" "/\\*" bold-italic)
  99            ("_\\*/" "/\\*_" underline-bold-italic))))
 100     (nconc
 101      (emchat-emphasis-custom-with-format
 102       (mapcar (lambda (spec)
 103                 (list (format format (car spec) (cadr spec))
 104                       (or (nth 3 spec) 2)
 105                       (or (nth 4 spec) 3)
 106                       (intern (format "emchat-emphasis-%s" (nth 2 spec)))))
 107               types))
 108      '(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
 109         2 3 emchat-emphasis-underline))))
 110   "*Alist that says how to fontify certain phrases.
 111 Each item looks like this:
 112
 113   (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline)
 114
 115 The first element is a regular expression to be matched.  The second
 116 is a number that says what regular expression grouping used to find
 117 the entire emphasised word.  The third is a number that says what
 118 regexp grouping should be displayed and highlighted.  The fourth
 119 is the face used for highlighting."
 120   :type
 121   '(repeat
 122     (menu-choice
 123      :format "%[Customizing Style%]\n%v"
 124      :indent 2
 125      (group :tag "Default"
 126             :value ("" 0 0 default)
 127             :value-create
 128             (lambda (widget)
 129               (let ((value (widget-get
 130                             (cadr (widget-get (widget-get widget :parent)
 131                                               :args))
 132                             :value)))
 133                 (if (not (eq (nth 2 value) 'default))
 134                     (widget-put
 135                      widget
 136                      :value
 137                      (emchat-emphasis-custom-value-to-external value))))
 138               (widget-group-value-create widget))
 139             regexp
 140             (integer :format "Match group: %v")
 141             (integer :format "Emphasise group: %v")
 142             face)
 143      (group :tag "Simple"
 144             :value (("_" . "_") nil default)
 145             (cons :format "%v"
 146                   (regexp :format "Start regexp: %v")
 147                   (regexp :format "End regexp: %v"))
 148             (boolean :format "Show start and end patterns: %[%v%]\n"
 149                      :on " On " :off " Off ")
 150             face)))
 151   :get #'(lambda (symbol)
 152            (mapcar #'emchat-emphasis-custom-value-to-internal
 153                    (default-value symbol)))
 154   :set #'(lambda (symbol value)
 155            (set-default symbol (mapcar #'emchat-emphasis-custom-value-to-external
 156                                        value)))
 157   :group 'emchat-emphasis)
 158
 159 (defcustom emchat-emphasise-whitespace-regexp "^[ \t]+\\|[ \t]*\n"
 160   "A regexp to describe whitespace which should not be emphasised.
 161 Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\".
 162 The former avoids underlining of leading and trailing whitespace,
 163 and the latter avoids underlining any whitespace at all."
 164   :group 'emchat-emphasis
 165   :type 'regexp)
 166
 167 (defcustom emchat-emphasis-url-regexp
 168   (concat "\\(https?://\\|s?ftp://\\|gopher://\\|telnet://"
 169           "\\|wais://\\|file:/\\|s?news:\\)"
 170           "[^]\t\n \"'()<>[^`{}]*[^]\t\n \"'()<>[^`{}.,;]+")
 171   "A regular expression matching URLs."
 172   :type 'regexp
 173   :group 'emchat-emphasis)
 174
 175 (defcustom emchat-emphasis-email-regexp
 176   "[-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+"
 177   "A regular expression matching email addresses."
 178   :type 'regexp
 179   :group 'emchat-emphasis)
 180
 181 (defcustom emchat-emphasis-man-regexp "\\b\\w+([1-9n])"
 182   "A regular expression matching unix manual pages.
 183
 184 For example, `xemacs\(1\)'."
 185   :type 'regexp
 186   :group 'emchat-emphasis)
 187
 188 (make-face 'emchat-emphasis-bold)
 189 (set-face-parent 'emchat-emphasis-bold 'bold)
 190
 191 (defcustom emchat-emphasis-bold 'emchat-emphasis-bold
 192   "Face used for displaying strong emphasised text (*word*)."
 193   :type 'face
 194   :group 'emchat-emphasis)
 195
 196 (make-face 'emchat-emphasis-italic)
 197 (set-face-parent 'emchat-emphasis-italic 'italic)
 198
 199 (defcustom emchat-emphasis-italic 'emchat-emphasis-italic
 200   "Face used for displaying italic emphasised text (/word/)."
 201   :type 'face
 202   :group 'emchat-emphasis)
 203
 204 (make-face 'emchat-emphasis-underline)
 205 (set-face-parent 'emchat-emphasis-underline 'underline)
 206
 207 (defcustom emchat-emphasis-underline 'emchat-emphasis-underline
 208   "Face used for displaying underlined emphasised text (_word_)."
 209   :type 'face
 210   :group 'emchat-emphasis)
 211
 212 (make-face 'emchat-emphasis-underline-bold)
 213 (set-face-parent 'emchat-emphasis-underline-bold 'bold)
 214 (set-face-property 'emchat-emphasis-underline-bold 'underline t)
 215
 216 (defcustom emchat-emphasis-underline-bold 'emchat-emphasis-underline-bold
 217   "Face used for displaying underlined bold emphasised text (_*word*_)."
 218   :type 'face
 219   :group 'emchat-emphasis)
 220
 221 (make-face 'emchat-emphasis-underline-italic)
 222 (set-face-parent 'emchat-emphasis-underline-italic 'italic)
 223 (set-face-property 'emchat-emphasis-underline-italic 'underline t)
 224
 225 (defcustom emchat-emphasis-underline-italic 'emchat-emphasis-underline-italic
 226   "Face used for displaying underlined italic emphasised text (_/word/_)."
 227   :type 'face
 228   :group 'emchat-emphasis)
 229
 230 (make-face 'emchat-emphasis-bold-italic)
 231 (set-face-parent 'emchat-emphasis-bold-italic 'bold-italic)
 232
 233 (defcustom emchat-emphasis-bold-italic 'emchat-emphasis-bold-italic
 234   "Face used for displaying bold italic emphasised text (/*word*/)."
 235   :type 'face
 236   :group 'emchat-emphasis)
 237
 238 (make-face 'emchat-emphasis-underline-bold-italic)
 239 (set-face-parent 'emchat-emphasis-underline-bold-italic 'bold-italic)
 240 (set-face-property 'emchat-emphasis-underline-bold-italic 'underline t)
 241
 242 (defcustom emchat-emphasis-underline-bold-italic
 243   'emchat-emphasis-underline-bold-italic
 244   "Face used for displaying underlined bold italic emphasised text.
 245 Example: (_/*word*/_)."
 246   :type 'face
 247   :group 'emchat-emphasis)
 248
 249 (make-face 'emchat-emphasis-strikethru)
 250 (set-face-property 'emchat-emphasis-strikethru 'strikethru t)
 251
 252 (defcustom emchat-emphasis-strikethru 'emchat-emphasis-strikethru
 253   "Face used for displaying strike-through text (-word-)."
 254   :type 'face
 255   :group 'emchat-emphasis)
 256
 257 (defface emchat-emphasis-highlight-words
 258   '((t (:background "black" :foreground "yellow")))
 259   "Face used for displaying highlighted words."
 260   :group 'emchat-emphasis)
 261
 262 ;;; Internal variables
 263
 264 (defun emchat-emphasis-treat-message (b e)
 265   "Emphasise text in region B E according to `emchat-emphasis-alist'."
 266   (let ((alist emchat-emphasis-alist)
 267         regexp elem beg invisible visible face)
 268     (save-excursion
 269       (save-restriction
 270         (narrow-to-region b e)
 271         (goto-char (point-min))
 272         (setq beg (point))
 273         (while (setq elem (pop alist))
 274           (goto-char beg)
 275           (setq regexp (car elem)
 276                 invisible (nth 1 elem)
 277                 visible (nth 2 elem)
 278                 face (nth 3 elem))
 279           (while (re-search-forward regexp nil t)
 280             (when (and (match-beginning visible) (match-beginning invisible))
 281               (put-text-property
 282                (match-beginning invisible) (match-end invisible) 'invisible t)
 283               (remove-text-properties
 284                (match-beginning visible) (match-end visible) '(invisible t))
 285               (put-text-property
 286                (match-beginning visible) (match-end visible) 'face face)
 287               (goto-char (match-end invisible)))))))))
 288
 289 (defun emchat-emphasis-visit-hyperlink-at-point ()
 290   "Follow the hyperlink at point in the EMchat log buffer.
 291
 292 This can either be a URL, in which case `browse-url' is called with
 293 the string of the extent as an arg.  Or it can be an email address, in
 294 which case `compose-mail' is called.  Or it can be a Unix manual page,
 295 where `manual-entry' is called."
 296   (interactive)
 297   (when (extentp (extent-at (point)))
 298     (let ((str (extent-string (extent-at (point)))))
 299       (cond ((string-match emchat-emphasis-url-regexp str)
 300              (browse-url str))
 301             ((string-match emchat-emphasis-email-regexp str)
 302              (compose-mail str))
 303             ((string-match emchat-emphasis-man-regexp str)
 304              (if (fboundp 'manual-entry)
 305                  (manual-entry str)
 306                (error 'unimplemented "Unix manual pages")))
 307             (t
 308              (error 'invalid-operation))))))
 309
 310 (defun emchat-emphasis-visit-hyperlink-at-mouse (event)
 311   "Follow the hyperlink at EVENT in the EMchat log buffer.
 312
 313 This can either be a URL, in which case `browse-url' is called with
 314 the string of the extent as an arg.  Or it can be an email address, in
 315 which case `compose-mail' is called.  Or it can be a Unix manual page,
 316 where `manual-entry' is called."
 317   (interactive "e")
 318   (when (extentp (extent-at-event event))
 319     (let ((str (extent-string (extent-at-event event))))
 320       (cond ((string-match emchat-emphasis-url-regexp str)
 321              (browse-url str))
 322             ((string-match emchat-emphasis-email-regexp str)
 323              (compose-mail str))
 324             ((string-match emchat-emphasis-man-regexp str)
 325              (if (fboundp 'manual-entry)
 326                  (manual-entry str)
 327                (error 'unimplemented "Unix manual pages")))
 328             (t
 329              (error 'invalid-operation))))))
 330
 331 (defun emchat-emphasis-hyperlink-message (b e)
 332   "Add hyperlinks to the message in region B E.
 333
 334 In other words, URLs, email addresses, and unix manual page names will
 335 be \"clickable\"."
 336   (save-excursion
 337     (save-restriction
 338       (narrow-to-region b e)
 339       (goto-char (point-min))
 340       (while (re-search-forward emchat-emphasis-url-regexp nil t)
 341         (let ((extent (make-extent (match-beginning 0) (match-end 0)))
 342               (echo "Mouse button2 -- Follow this link."))
 343           (set-extent-property extent 'face 'widget-button-face)
 344           (set-extent-property extent 'mouse-face 'highlight)
 345           (set-extent-property extent 'keymap emchat-hyperlink-map)
 346           (set-extent-property extent 'help-echo echo)
 347           (set-extent-property extent 'balloon-help echo)
 348           (set-extent-property extent 'duplicable t)))
 349       (while (re-search-forward emchat-emphasis-email-regexp nil t)
 350         (let ((extent (make-extent (match-beginning 0) (match-end 0)))
 351               (echo "Mouse button2 -- Compose mail."))
 352           (set-extent-property extent 'face 'emchat-emphasis-highlight-words)
 353           (set-extent-property extent 'mouse-face 'highlight)
 354           (set-extent-property extent 'keymap emchat-hyperlink-map)
 355           (set-extent-property extent 'help-echo echo)
 356           (set-extent-property extent 'balloon-help echo)
 357           (set-extent-property extent 'duplicable t)))
 358       (while (re-search-forward emchat-emphasis-man-regexp nil t)
 359         (let ((extent (make-extent (match-beginning 0) (match-end 0)))
 360               (echo "Mouse button2 -- Read this manual."))
 361           (set-extent-property extent 'face 'man-xref)
 362           (set-extent-property extent 'mouse-face 'highlight)
 363           (set-extent-property extent 'keymap emchat-hyperlink-map)
 364           (set-extent-property extent 'help-echo echo)
 365           (set-extent-property extent 'balloon-help echo)
 366           (set-extent-property extent 'duplicable t))))))
 367
 368 (provide 'emchat-emphasis)
 369 ;;; emchat-emphasis.el ends here
 370