muse-colors.el

   1 ;;; muse-colors.el --- Coloring and highlighting used by Muse
   2
   3 ;; Copyright (C) 2004 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 5 6)))
  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     ("\\*+" ?* 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 (defvar font-lock-mode nil)
 263 (defvar font-lock-multiline nil)
 264
 265 (defun muse-use-font-lock ()
 266   (set (make-local-variable 'font-lock-multiline) 'undecided)
 267   (set (make-local-variable 'font-lock-defaults)
 268        `(nil t nil nil 'beginning-of-line
 269          (font-lock-fontify-region-function . muse-colors-region)
 270          (font-lock-unfontify-region-function
 271           . muse-unhighlight-region)))
 272   (set (make-local-variable 'font-lock-fontify-region-function)
 273        'muse-colors-region)
 274   (set (make-local-variable 'font-lock-unfontify-region-function)
 275        'muse-unhighlight-region)
 276   (font-lock-mode t))
 277
 278 (defun muse-colors-buffer ()
 279   "Re-highlight the entire Muse buffer."
 280   (interactive)
 281   (muse-colors-region (point-min) (point-max) t))
 282
 283 (defun muse-colors-region (beg end &optional verbose)
 284   "Apply highlighting according to `muse-colors-markup'.
 285 Note that this function should NOT change the buffer, nor should any
 286 of the functions listed in `muse-colors-markup'."
 287   (let ((buffer-undo-list t)
 288         (inhibit-read-only t)
 289         (inhibit-point-motion-hooks t)
 290         (inhibit-modification-hooks t)
 291         (modified-p (buffer-modified-p))
 292         deactivate-mark)
 293     (unwind-protect
 294         (save-excursion
 295           (save-restriction
 296             (widen)
 297             ;; check to see if we should expand the beg/end area for
 298             ;; proper multiline matches
 299             (when (and font-lock-multiline
 300                        (> beg (point-min))
 301                        (get-text-property (1- beg) 'font-lock-multiline))
 302               ;; We are just after or in a multiline match.
 303               (setq beg (or (previous-single-property-change
 304                              beg 'font-lock-multiline)
 305                             (point-min)))
 306               (goto-char beg)
 307               (setq beg (line-beginning-position)))
 308             (when font-lock-multiline
 309               (setq end (or (text-property-any end (point-max)
 310                                                'font-lock-multiline nil)
 311                             (point-max))))
 312             (goto-char end)
 313             (setq end (line-beginning-position 2))
 314             ;; Undo any fontification in the area.
 315             (font-lock-unfontify-region beg end)
 316             ;; And apply fontification based on `muse-colors-markup'
 317             (let ((len (float (- end beg)))
 318                   (case-fold-search nil))
 319               (goto-char beg)
 320               (while (re-search-forward muse-colors-regexp end t)
 321                 (if verbose
 322                     (message "Highlighting buffer...%d%%"
 323                              (* (/ (float (- (point) beg)) len) 100)))
 324                 (funcall (aref muse-colors-vector
 325                                (char-after (match-beginning 0)))))
 326               (run-hook-with-args 'muse-colors-buffer-hook
 327                                   beg end verbose)
 328               (if verbose (message "Highlighting buffer...done")))))
 329       (set-buffer-modified-p modified-p))))
 330
 331 (defcustom muse-colors-tags
 332   '(("example" t nil muse-colors-example-tag))
 333   "A list of tag specifications for specially highlighting text.
 334 XML-style tags are the best way to add custom highlighting to Muse.
 335 This is easily accomplished by customizing this list of markup tags.
 336
 337 For each entry, the name of the tag is given, whether it expects
 338 a closing tag and/or an optional set of attributes, and a
 339 function that performs whatever action is desired within the
 340 delimited region.
 341
 342 The function is called with three arguments, the beginning and
 343 end of the region surrounded by the tags. If properties are
 344 allowed, they are passed as a third argument in the form of an
 345 alist. The `end' argument to the function is the last character
 346 of the enclosed tag or region.
 347
 348 Functions should not modify the contents of the buffer.")
 349
 350 (defun muse-colors-custom-tags ()
 351   "Highlight `muse-colors-tags'."
 352   (let ((tag-info (muse-colors-tag-info (match-string 4))))
 353     (when tag-info
 354       (let ((closed-tag (match-string 3))
 355             (start (match-beginning 0))
 356             (beg (point)) end attrs)
 357         (when (nth 2 tag-info)
 358           (let ((attrstr (match-string 2)))
 359             (while (and attrstr
 360                         (string-match (concat "\\([^"
 361                                               muse-regexp-space
 362                                               "=]+\\)\\(=\""
 363                                               "\\([^\"]+\\)\"\\)?")
 364                                       attrstr))
 365               (let ((attr (cons (downcase
 366                                  (match-string-no-properties 1 attrstr))
 367                                 (match-string-no-properties 3 attrstr))))
 368                 (setq attrstr (replace-match "" t t attrstr))
 369                 (if attrs
 370                     (nconc attrs (list attr))
 371                   (setq attrs (list attr)))))))
 372         (if (and (cadr tag-info) (not closed-tag))
 373             (if (search-forward (concat "</" (car tag-info) ">") nil t)
 374                 (setq end (match-end 0))
 375               (setq tag-info nil)))
 376         (when tag-info
 377           (let ((args (list start end)))
 378             (if (nth 2 tag-info)
 379                 (nconc args (list attrs)))
 380             (apply (nth 3 tag-info) args)))))))
 381
 382 (defsubst muse-colors-tag-info (tagname &rest args)
 383   (assoc tagname muse-colors-tags))
 384
 385 (defun muse-colors-example-tag (beg end)
 386   "Strip properties from stuff in example."
 387   (set-text-properties beg end nil)
 388   (goto-char end))
 389
 390 (defun muse-unhighlight-region (begin end &optional verbose)
 391   "Remove all visual highlights in the buffer (except font-lock)."
 392   (let ((buffer-undo-list t)
 393         (inhibit-read-only t)
 394         (inhibit-point-motion-hooks t)
 395         (inhibit-modification-hooks t)
 396         (modified-p (buffer-modified-p))
 397         deactivate-mark)
 398     (unwind-protect
 399         (remove-text-properties
 400          begin end '(face nil font-lock-multiline nil
 401                           invisible nil intangible nil display nil
 402                           mouse-face nil keymap nil help-echo nil))
 403       (set-buffer-modified-p modified-p))))
 404
 405 (defvar muse-mode-local-map
 406   (let ((map (make-sparse-keymap)))
 407     (define-key map [return] 'muse-follow-name-at-point)
 408     (define-key map [(control ?m)] 'muse-follow-name-at-point)
 409     (define-key map [(shift return)] 'muse-follow-name-at-point-other-window)
 410     (if (featurep 'xemacs)
 411         (progn
 412           (define-key map [(button2)] 'muse-follow-name-at-mouse)
 413           (define-key map [(shift button2)] 'muse-follow-name-at-mouse-other-window))
 414       (define-key map [(shift control ?m)] 'muse-follow-name-at-point-other-window)
 415       (define-key map [mouse-2] 'muse-follow-name-at-mouse)
 416       (define-key map [(shift mouse-2)] 'muse-follow-name-at-mouse-other-window)
 417       (unless (eq emacs-major-version 21)
 418         (set-keymap-parent map muse-mode-map)))
 419     map)
 420   "Local keymap used by Muse while on a link.")
 421
 422 (defvar muse-keymap-property
 423   (if (or (featurep 'xemacs)
 424           (>= emacs-major-version 21))
 425       'keymap
 426     'local-map))
 427
 428 (defsubst muse-link-properties (help-str &optional face)
 429   (append (if face
 430               (list 'face face 'rear-nonsticky t
 431                     muse-keymap-property muse-mode-local-map)
 432             (list 'invisible t 'intangible t 'rear-nonsticky t
 433                   muse-keymap-property muse-mode-local-map))
 434           (list 'mouse-face 'highlight
 435                 'help-echo help-str
 436                 muse-keymap-property muse-mode-local-map)))
 437
 438 (defun muse-link-face (link-name)
 439   "Return the type of LINK-NAME as a face symbol - either a normal link, or a
 440 bad-link face"
 441   (save-match-data
 442     (if (or (string-match muse-file-regexp link-name)
 443             (string-match muse-url-regexp link-name))
 444         'muse-link-face
 445       (if (not (featurep 'muse-project))
 446           'muse-link-face
 447         (if (string-match "#" link-name)
 448             (setq link-name (substring link-name 0 (match-beginning 0))))
 449         (if (or (and (muse-project-of-file)
 450                      (muse-project-page-file link-name muse-current-project t))
 451                 (file-exists-p link-name))
 452             'muse-link-face
 453           'muse-bad-link-face)))))
 454
 455 (defun muse-colors-link ()
 456   (when (eq ?\[ (char-after (match-beginning 0)))
 457     (let* ((link (match-string-no-properties 2))
 458            (desc (match-string-no-properties 3))
 459            (props (muse-link-properties
 460                    desc (muse-link-face (match-string 2))))
 461            (invis-props (append props (muse-link-properties desc))))
 462       (if desc
 463           (progn
 464             ;; we put the normal face properties on the invisible
 465             ;; portion too, since emacs sometimes will position
 466             ;; the cursor on an intangible character
 467             (add-text-properties (match-beginning 0)
 468                                  (match-beginning 3) invis-props)
 469             (add-text-properties (match-beginning 3) (match-end 3) props)
 470             (add-text-properties (match-end 3) (match-end 0) invis-props))
 471         (add-text-properties (match-beginning 0)
 472                              (match-beginning 2) invis-props)
 473         (add-text-properties (match-beginning 2) (match-end 0) props)
 474         (add-text-properties (match-end 2) (match-end 0) invis-props)))
 475     (goto-char (match-end 0))
 476     (add-text-properties
 477      (match-beginning 0) (match-end 0)
 478      (muse-link-properties (match-string-no-properties 0)
 479                            (muse-link-face (match-string 2))))
 480     (goto-char (match-end 0))))
 481
 482 (defun muse-colors-title ()
 483   (add-text-properties (+ 7 (match-beginning 0))
 484                        (line-end-position)
 485                        '(face muse-header-1)))
 486
 487 (provide 'muse-colors)
 488
 489 ;;; muse-colors.el ends here