muse-colors.el

   1 ;;; muse-colors.el --- Coloring and highlighting used by Muse
   2
   3 ;; Copyright (C) 2004, 2005  Free Software Foundation, Inc.
   4
   5 ;; Emacs Lisp Archive Entry
   6 ;; Filename: muse-colors.el
   7 ;; Version: 3.00 ALPHA
   8 ;; Date: Thu 11-Mar-2004
   9 ;; Keywords: hypermedia
  10 ;; Author: John Wiegley (johnw AT gnu DOT org)
  11 ;; Maintainer: Michael Olson (mwolson AT gnu DOT org)
  12 ;; URL: http://www.mwolson.org/projects/MuseMode.html
  13 ;; Compatibility: Emacs21
  14
  15 ;; This file is not part of GNU Emacs.
  16
  17 ;; This is free software; you can redistribute it and/or modify it under
  18 ;; the terms of the GNU General Public License as published by the Free
  19 ;; Software Foundation; either version 2, or (at your option) any later
  20 ;; version.
  21 ;;
  22 ;; This is distributed in the hope that it will be useful, but WITHOUT
  23 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  24 ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  25 ;; for more details.
  26 ;;
  27 ;; You should have received a copy of the GNU General Public License
  28 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  29 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  30 ;; MA 02111-1307, USA.
  31
  32 ;;; Commentary:
  33
  34 ;; This file is the part of the Muse project that describes regexps
  35 ;; that are used throughout the project.
  36
  37 ;;;_ + Startup
  38
  39 ;; To be written.
  40
  41 ;;;_ + Usage
  42
  43 ;;;_ + Contributors
  44
  45 ;; Lan Yufeng (nlany DOT web AT gmail DOT com) found an error where
  46 ;; headings were being given the wrong face, contributing a patch to
  47 ;; fix this.
  48
  49 ;;; Code:
  50
  51 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  52 ;;
  53 ;; Emacs Muse Highlighting
  54 ;;
  55 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  56
  57 (require 'muse-mode)
  58 (require 'muse-regexps)
  59 (require 'font-lock)
  60
  61 (defgroup muse-colors nil
  62   "Options controlling the behaviour of Emacs Muse highlighting.
  63 See `muse-colors-buffer' for more information."
  64   :group 'muse-mode)
  65
  66 (defun muse-make-faces ()
  67   (mapc (lambda (newsym)
  68           (let (num)
  69             (setq num newsym)
  70             (setq newsym (intern (concat "muse-header-"
  71                                          (int-to-string num))))
  72             (cond
  73              ((featurep 'xemacs)
  74               (eval `(defface ,newsym
  75                        '((t (:size
  76                              ,(nth (1- num) '("24pt" "18pt" "14pt" "12pt"))
  77                              :bold t)))
  78                        "Muse header face"
  79                        :group 'muse-colors)))
  80              ((< emacs-major-version 21)
  81               (copy-face 'default newsym))
  82              (t
  83               (eval `(defface ,newsym
  84                        '((t (:height ,(1+ (* 0.1 (- 5 num)))
  85                                      :inherit variable-pitch
  86                                      :weight bold)))
  87                        "Muse header face"
  88                        :group 'muse-colors))))))
  89         '(1 2 3 4)))
  90 (muse-make-faces)
  91
  92 (defface muse-link-face
  93   '((((class color) (background light))
  94      (:foreground "green" :underline "green" :bold t))
  95     (((class color) (background dark))
  96      (:foreground "cyan" :underline "cyan" :bold t))
  97     (t (:bold t)))
  98   "Face for Muse cross-references."
  99   :group 'muse-colors)
 100
 101 (defface muse-bad-link-face
 102   '((((class color) (background light))
 103      (:foreground "red" :underline "red" :bold t))
 104     (((class color) (background dark))
 105      (:foreground "coral" :underline "coral" :bold t))
 106     (t (:bold t)))
 107   "Face for bad Muse cross-references."
 108   :group 'muse-colors)
 109
 110 (defcustom muse-colors-buffer-hook nil
 111   "A hook run after a region is highlighted.
 112 Each function receives three arguments: BEG END VERBOSE.
 113 BEG and END mark the range being highlighted, and VERBOSE specifies
 114 whether progress messages should be displayed to the user."
 115   :type 'hook
 116   :group 'muse-colors)
 117
 118 (defvar muse-colors-regexp nil)
 119 (defvar muse-colors-vector nil)
 120
 121 (defun muse-configure-highlighting (sym val)
 122   (setq muse-colors-regexp
 123         (concat "\\(" (mapconcat (function
 124                                   (lambda (rule)
 125                                     (if (symbolp (car rule))
 126                                         (symbol-value (car rule))
 127                                       (car rule)))) val "\\|") "\\)")
 128         muse-colors-vector (make-vector 128 nil))
 129   (let ((rules val))
 130     (while rules
 131       (if (eq (cadr (car rules)) t)
 132           (let ((i 0) (l 128))
 133             (while (< i l)
 134               (unless (aref muse-colors-vector i)
 135                 (aset muse-colors-vector i (nth 2 (car rules))))
 136               (setq i (1+ i))))
 137         (aset muse-colors-vector (cadr (car rules))
 138               (nth 2 (car rules))))
 139       (setq rules (cdr rules))))
 140   (set sym val))
 141
 142 (eval-when-compile
 143   (defvar end))
 144
 145 (defun muse-colors-emphasized ()
 146   ;; here we need to check four different points - the start and end of the
 147   ;; leading *s, and the start and end of the trailing *s. we allow the
 148   ;; outsides to be surrounded by whitespace or punctuation, but no word
 149   ;; characters, and the insides must not be surrounded by whitespace or
 150   ;; punctuation. thus the following are valid:
 151   ;; " *foo bar* "
 152   ;; "**foo**,"
 153   ;; and the following is invalid:
 154   ;; "** testing **"
 155   (let* ((beg (match-beginning 0))
 156          (e1 (match-end 0))
 157          (leader (- e1 beg))
 158          b2 e2 multiline)
 159     (unless (get-text-property beg 'invisible)
 160       ;; check if it's a header
 161       (if (eq (char-after e1) ?\ )
 162           (if (or (= beg (point-min))
 163                   (eq (char-before beg) ?\n))
 164               (add-text-properties
 165                (line-beginning-position) (line-end-position)
 166                (list 'face (intern (concat "muse-header-"
 167                                            (int-to-string leader))))))
 168         (save-excursion
 169           (skip-chars-forward "^*\n" end)
 170           (when (eq (char-after) ?\n)
 171             (setq multiline t)
 172             (skip-chars-forward "^*" end))
 173           (setq b2 (point))
 174           (skip-chars-forward "*" end)
 175           (setq e2 (point))
 176           (add-text-properties beg e1 '(invisible t))
 177           (add-text-properties
 178            e1 b2 (list 'face (cond ((= leader 1) 'italic)
 179                                    ((= leader 2) 'bold)
 180                                    ((= leader 3) 'bold-italic))))
 181           (add-text-properties b2 e2 '(invisible t))
 182           (goto-char e1)
 183           (if multiline
 184               (add-text-properties beg e2 '(font-lock-multiline t))))))))
 185
 186 (defun muse-colors-underlined ()
 187   (let ((start (match-beginning 0)))
 188     (when (search-forward "_" end t)
 189       (add-text-properties start (+ start 1) '(invisible t))
 190       (add-text-properties (+ start 1) (match-beginning 0) '(face underline))
 191       (add-text-properties (match-beginning 0) (match-end 0) '(invisible t)))))
 192
 193 (defun muse-colors-verbatim ()
 194   (skip-chars-forward (concat "^" muse-regexp-space "=>") end))
 195
 196 (defcustom muse-colors-markup
 197   `(;; render in teletype and suppress further parsing
 198     (,(concat "\\b=[^"
 199               muse-regexp-space
 200               "=>]")
 201      ?= muse-colors-verbatim)
 202
 203     ;; make emphasized text appear emphasized
 204     ("\\*\\{1,4\\}" ?* muse-colors-emphasized)
 205
 206     ;; make underlined text appear underlined
 207     (,(concat "_[^"
 208               muse-regexp-blank
 209               "_]")
 210      ?_ muse-colors-underlined)
 211
 212     ("^#title" ?\# muse-colors-title)
 213
 214     (muse-link-regexp ?\[ muse-colors-link)
 215
 216     ;; highlight any markup tags encountered
 217     (muse-tag-regexp ?\< muse-colors-custom-tags)
 218     )
 219   "Expressions to highlight an Emacs Muse buffer.
 220 These are arranged in a rather special fashion, so as to be as quick as
 221 possible.
 222
 223 Each element of the list is itself a list, of the form:
 224
 225   (LOCATE-REGEXP TEST-CHAR MATCH-FUNCTION)
 226
 227 LOCATE-REGEXP is a partial regexp, and should be the smallest possible
 228 regexp to differentiate this rule from other rules.  It may also be a
 229 symbol containing such a regexp.  The buffer region is scanned only
 230 once, and LOCATE-REGEXP indicates where the scanner should stop to
 231 look for highlighting possibilities.
 232
 233 TEST-CHAR is a char or t.  The character should match the beginning
 234 text matched by LOCATE-REGEXP.  These chars are used to build a vector
 235 for fast MATCH-FUNCTION calling.
 236
 237 MATCH-FUNCTION is the function called when a region has been
 238 identified.  It is responsible for adding the appropriate text
 239 properties to change the appearance of the buffer.
 240
 241 This markup is used to modify the appearance of the original text to
 242 make it look more like the published HTML would look (like making some
 243 markup text invisible, inlining images, etc).
 244
 245 font-lock is used to apply the markup rules, so that they can happen
 246 on a deferred basis.  They are not always accurate, but you can use
 247 \\[font-lock-fontifty-block] near the point of error to force
 248 fontification in that area.
 249
 250 Lastly, none of the regexp should contain grouping elements that will
 251 affect the match data results."
 252   :type '(repeat
 253           (list :tag "Highlight rule"
 254                 (choice (regexp :tag "Locate regexp")
 255                         (symbol :tag "Regexp symbol"))
 256                 (choice (character :tag "Confirm character")
 257                         (const :tag "Default rule" t))
 258                 function))
 259   :set 'muse-configure-highlighting
 260   :group 'muse-colors)
 261
 262 ;; XEmacs users don't have `font-lock-multiline'.
 263 (unless (boundp 'font-lock-multiline)
 264   (defvar font-lock-multiline nil))
 265
 266 (defun muse-use-font-lock ()
 267   (set (make-local-variable 'font-lock-multiline) 'undecided)
 268   (set (make-local-variable 'font-lock-defaults)
 269        `(nil t nil nil 'beginning-of-line
 270          (font-lock-fontify-region-function . muse-colors-region)
 271          (font-lock-unfontify-region-function
 272           . muse-unhighlight-region)))
 273   (set (make-local-variable 'font-lock-fontify-region-function)
 274        'muse-colors-region)
 275   (set (make-local-variable 'font-lock-unfontify-region-function)
 276        'muse-unhighlight-region)
 277   (font-lock-mode t))
 278
 279 (defun muse-colors-buffer ()
 280   "Re-highlight the entire Muse buffer."
 281   (interactive)
 282   (muse-colors-region (point-min) (point-max) t))
 283
 284 (defun muse-colors-region (beg end &optional verbose)
 285   "Apply highlighting according to `muse-colors-markup'.
 286 Note that this function should NOT change the buffer, nor should any
 287 of the functions listed in `muse-colors-markup'."
 288   (let ((buffer-undo-list t)
 289         (inhibit-read-only t)
 290         (inhibit-point-motion-hooks t)
 291         (inhibit-modification-hooks t)
 292         (modified-p (buffer-modified-p))
 293         deactivate-mark)
 294     (unwind-protect
 295         (save-excursion
 296           (save-restriction
 297             (widen)
 298             ;; check to see if we should expand the beg/end area for
 299             ;; proper multiline matches
 300             (when (and font-lock-multiline
 301                        (> beg (point-min))
 302                        (get-text-property (1- beg) 'font-lock-multiline))
 303               ;; We are just after or in a multiline match.
 304               (setq beg (or (previous-single-property-change
 305                              beg 'font-lock-multiline)
 306                             (point-min)))
 307               (goto-char beg)
 308               (setq beg (line-beginning-position)))
 309             (when font-lock-multiline
 310               (setq end (or (text-property-any end (point-max)
 311                                                'font-lock-multiline nil)
 312                             (point-max))))
 313             (goto-char end)
 314             (setq end (line-beginning-position 2))
 315             ;; Undo any fontification in the area.
 316             (font-lock-unfontify-region beg end)
 317             ;; And apply fontification based on `muse-colors-markup'
 318             (let ((len (float (- end beg)))
 319                   (case-fold-search nil)
 320                   markup-func)
 321               (goto-char beg)
 322               (while (re-search-forward muse-colors-regexp end t)
 323                 (if verbose
 324                     (message "Highlighting buffer...%d%%"
 325                              (* (/ (float (- (point) beg)) len) 100)))
 326                 (setq markup-func
 327                       (aref muse-colors-vector
 328                             (char-after (match-beginning 0))))
 329                 (when markup-func (funcall markup-func)))
 330               (run-hook-with-args 'muse-colors-buffer-hook
 331                                   beg end verbose)
 332               (if verbose (message "Highlighting buffer...done")))))
 333       (set-buffer-modified-p modified-p))))
 334
 335 (defcustom muse-colors-tags
 336   '(("example" t nil muse-colors-example-tag))
 337   "A list of tag specifications for specially highlighting text.
 338 XML-style tags are the best way to add custom highlighting to Muse.
 339 This is easily accomplished by customizing this list of markup tags.
 340
 341 For each entry, the name of the tag is given, whether it expects
 342 a closing tag and/or an optional set of attributes, and a
 343 function that performs whatever action is desired within the
 344 delimited region.
 345
 346 The function is called with three arguments, the beginning and
 347 end of the region surrounded by the tags. If properties are
 348 allowed, they are passed as a third argument in the form of an
 349 alist. The `end' argument to the function is the last character
 350 of the enclosed tag or region.
 351
 352 Functions should not modify the contents of the buffer.")
 353
 354 (defsubst muse-colors-tag-info (tagname &rest args)
 355   (assoc tagname muse-colors-tags))
 356
 357 (defun muse-colors-custom-tags ()
 358   "Highlight `muse-colors-tags'."
 359   (let ((tag-info (muse-colors-tag-info (match-string 4))))
 360     (when tag-info
 361       (let ((closed-tag (match-string 3))
 362             (start (match-beginning 0))
 363             (beg (point)) end attrs)
 364         (when (nth 2 tag-info)
 365           (let ((attrstr (match-string 2)))
 366             (while (and attrstr
 367                         (string-match (concat "\\([^"
 368                                               muse-regexp-space
 369                                               "=]+\\)\\(=\""
 370                                               "\\([^\"]+\\)\"\\)?")
 371                                       attrstr))
 372               (let ((attr (cons (downcase
 373                                  (match-string-no-properties 1 attrstr))
 374                                 (match-string-no-properties 3 attrstr))))
 375                 (setq attrstr (replace-match "" t t attrstr))
 376                 (if attrs
 377                     (nconc attrs (list attr))
 378                   (setq attrs (list attr)))))))
 379         (if (and (cadr tag-info) (not closed-tag))
 380             (if (search-forward (concat "</" (car tag-info) ">") nil t)
 381                 (setq end (match-end 0))
 382               (setq tag-info nil)))
 383         (when tag-info
 384           (let ((args (list start end)))
 385             (if (nth 2 tag-info)
 386                 (nconc args (list attrs)))
 387             (apply (nth 3 tag-info) args)))))))
 388
 389 (defun muse-colors-example-tag (beg end)
 390   "Strip properties from stuff in example."
 391   (set-text-properties beg end nil)
 392   (goto-char end))
 393
 394 (defun muse-unhighlight-region (begin end &optional verbose)
 395   "Remove all visual highlights in the buffer (except font-lock)."
 396   (let ((buffer-undo-list t)
 397         (inhibit-read-only t)
 398         (inhibit-point-motion-hooks t)
 399         (inhibit-modification-hooks t)
 400         (modified-p (buffer-modified-p))
 401         deactivate-mark)
 402     (unwind-protect
 403         (remove-text-properties
 404          begin end '(face nil font-lock-multiline nil
 405                           invisible nil intangible nil display nil
 406                           mouse-face nil keymap nil help-echo nil))
 407       (set-buffer-modified-p modified-p))))
 408
 409 (defvar muse-mode-local-map
 410   (let ((map (make-sparse-keymap)))
 411     (define-key map [return] 'muse-follow-name-at-point)
 412     (define-key map [(control ?m)] 'muse-follow-name-at-point)
 413     (define-key map [(shift return)] 'muse-follow-name-at-point-other-window)
 414     (if (featurep 'xemacs)
 415         (progn
 416           (define-key map [(button2)] 'muse-follow-name-at-mouse)
 417           (define-key map [(shift button2)] 'muse-follow-name-at-mouse-other-window))
 418       (define-key map [(shift control ?m)] 'muse-follow-name-at-point-other-window)
 419       (define-key map [mouse-2] 'muse-follow-name-at-mouse)
 420       (define-key map [(shift mouse-2)] 'muse-follow-name-at-mouse-other-window)
 421       (unless (eq emacs-major-version 21)
 422         (set-keymap-parent map muse-mode-map)))
 423     map)
 424   "Local keymap used by Muse while on a link.")
 425
 426 (defvar muse-keymap-property
 427   (if (or (featurep 'xemacs)
 428           (>= emacs-major-version 21))
 429       'keymap
 430     'local-map))
 431
 432 (defsubst muse-link-properties (help-str &optional face)
 433   (append (if face
 434               (list 'face face 'rear-nonsticky t
 435                     muse-keymap-property muse-mode-local-map)
 436             (list 'invisible t 'intangible t 'rear-nonsticky t
 437                   muse-keymap-property muse-mode-local-map))
 438           (list 'mouse-face 'highlight
 439                 'help-echo help-str
 440                 muse-keymap-property muse-mode-local-map)))
 441
 442 (defun muse-link-face (link-name)
 443   "Return the type of LINK-NAME as a face symbol - either a normal link, or a
 444 bad-link face"
 445   (save-match-data
 446     (if (or (string-match muse-file-regexp link-name)
 447             (string-match muse-url-regexp link-name))
 448         'muse-link-face
 449       (if (not (featurep 'muse-project))
 450           'muse-link-face
 451         (if (string-match "#" link-name)
 452             (setq link-name (substring link-name 0 (match-beginning 0))))
 453         (if (or (and (muse-project-of-file)
 454                      (muse-project-page-file link-name muse-current-project t))
 455                 (file-exists-p link-name))
 456             'muse-link-face
 457           'muse-bad-link-face)))))
 458
 459 (defun muse-colors-link ()
 460   (when (eq ?\[ (char-after (match-beginning 0)))
 461     ;; remove flyspell overlays
 462     (when (fboundp 'flyspell-unhighlight-at)
 463       (let ((cur (match-beginning 0)))
 464         (while (> (match-end 0) cur)
 465           (flyspell-unhighlight-at cur)
 466           (setq cur (1+ cur)))))
 467     (let* ((link (match-string-no-properties 2))
 468            (desc (match-string-no-properties 3))
 469            (props (muse-link-properties
 470                    desc (muse-link-face (match-string 2))))
 471            (invis-props (append props (muse-link-properties desc))))
 472       (if desc
 473           (progn
 474             ;; we put the normal face properties on the invisible
 475             ;; portion too, since emacs sometimes will position
 476             ;; the cursor on an intangible character
 477             (add-text-properties (match-beginning 0)
 478                                  (match-beginning 3) invis-props)
 479             (add-text-properties (match-beginning 3) (match-end 3) props)
 480             (add-text-properties (match-end 3) (match-end 0) invis-props))
 481         (add-text-properties (match-beginning 0)
 482                              (match-beginning 2) invis-props)
 483         (add-text-properties (match-beginning 2) (match-end 0) props)
 484         (add-text-properties (match-end 2) (match-end 0) invis-props)))
 485     (goto-char (match-end 0))
 486     (add-text-properties
 487      (match-beginning 0) (match-end 0)
 488      (muse-link-properties (match-string-no-properties 0)
 489                            (muse-link-face (match-string 2))))
 490     (goto-char (match-end 0))))
 491
 492 (defun muse-colors-title ()
 493   (add-text-properties (+ 7 (match-beginning 0))
 494                        (line-end-position)
 495                        '(face muse-header-1)))
 496
 497 (provide 'muse-colors)
 498
 499 ;;; muse-colors.el ends here