code.delx.au - gnu-emacs-elpa/blob - packages/muse/muse-colors.el

   1 ;;; muse-colors.el --- coloring and highlighting used by Muse
   2
   3 ;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010
   4 ;;   Free Software Foundation, Inc.
   5
   6 ;; Author: John Wiegley (johnw AT gnu DOT org)
   7 ;; Keywords: hypermedia
   8 ;; Date: Thu 11-Mar-2004
   9
  10 ;; This file is part of Emacs Muse.  It is not part of GNU Emacs.
  11
  12 ;; Emacs Muse is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published
  14 ;; by the Free Software Foundation; either version 3, or (at your
  15 ;; option) any later version.
  16
  17 ;; Emacs Muse is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with Emacs Muse; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;;; Contributors:
  30
  31 ;; Lan Yufeng (nlany DOT web AT gmail DOT com) found an error where
  32 ;; headings were being given the wrong face, contributing a patch to
  33 ;; fix this.
  34
  35 ;; Sergey Vlasov (vsu AT altlinux DOT ru) fixed an issue with coloring
  36 ;; links that are in consecutive lines.
  37
  38 ;; Jim Ottaway ported the <lisp> tag from emacs-wiki.
  39
  40 ;; Per B. Sederberg (per AT med DOT upenn DOT edu) contributed the
  41 ;; viewing of inline images.
  42
  43 ;;; Code:
  44
  45 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  46 ;;
  47 ;; Emacs Muse Highlighting
  48 ;;
  49 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  50
  51 (require 'muse-mode)
  52 (require 'muse-regexps)
  53 (require 'font-lock)
  54
  55 (defgroup muse-colors nil
  56   "Options controlling the behavior of Emacs Muse highlighting.
  57 See `muse-colors-buffer' for more information."
  58   :group 'muse-mode)
  59
  60 (defcustom muse-colors-autogen-headings t
  61   "Specify whether the heading faces should be auto-generated.
  62 The default is to scale them.
  63
  64 Choosing `outline' will copy the colors from the outline-mode
  65 headings.
  66
  67 If you want to customize each of the headings individually, set
  68 this to nil."
  69   :type '(choice (const :tag "Default (scaled) headings" t)
  70                  (const :tag "Use outline-mode headings" outline)
  71                  (const :tag "Don't touch the headings" nil))
  72   :group 'muse-colors)
  73
  74 (defcustom muse-colors-evaluate-lisp-tags t
  75   "Specify whether to evaluate the contents of <lisp> tags at
  76 display time.  If nil, don't evaluate them.  If non-nil, evaluate
  77 them.
  78
  79 The actual contents of the buffer are not changed, only the
  80 displayed text."
  81   :type 'boolean
  82   :group 'muse-colors)
  83
  84 (defcustom muse-colors-inline-images t
  85   "Specify whether to inline images inside the Emacs buffer.  If
  86 nil, don't inline them.  If non-nil, an image link will be
  87 replaced by the image.
  88
  89 The actual contents of the buffer are not changed, only whether
  90 an image is displayed."
  91   :type 'boolean
  92   :group 'muse-colors)
  93
  94 (defcustom muse-colors-inline-image-method 'default-directory
  95   "Determine how to locate inline images.
  96 Setting this to 'default-directory uses the current directory of
  97 the current Muse buffer.
  98
  99 Setting this to a function calls that function with the filename
 100 of the image to be inlined.  The value that is returned will be
 101 used as the filename of the image."
 102   :type '(choice (const :tag "Current directory" default-directory)
 103                  (const :tag "Publishing directory"
 104                         muse-colors-use-publishing-directory)
 105                  (function :tag "Custom function"))
 106   :group 'muse-colors)
 107
 108 (defvar muse-colors-region-end nil
 109   "Indicate the end of the region that is currently being font-locked.")
 110 (make-variable-buffer-local 'muse-colors-region-end)
 111
 112 ;;;###autoload
 113 (defun muse-colors-toggle-inline-images ()
 114   "Toggle display of inlined images on/off."
 115   (interactive)
 116   ;; toggle the custom setting
 117   (if (not muse-colors-inline-images)
 118       (setq muse-colors-inline-images t)
 119     (setq muse-colors-inline-images nil))
 120   ;; reprocess the buffer
 121   (muse-colors-buffer)
 122   ;; display informative message
 123   (if muse-colors-inline-images
 124       (message "Images are now displayed inline")
 125     (message "Images are now displayed as links")))
 126
 127 (defvar muse-colors-outline-faces-list
 128   (if (facep 'outline-1)
 129       '(outline-1 outline-2 outline-3 outline-4 outline-5)
 130     ;; these are equivalent in coloring to the outline faces
 131     '(font-lock-function-name-face
 132       font-lock-variable-name-face
 133       font-lock-keyword-face
 134       font-lock-builtin-face
 135       font-lock-comment-face))
 136   "Outline faces to use when assigning Muse header faces.")
 137
 138 (defun muse-make-faces-default (&optional later)
 139   "Generate the default face definitions for headers."
 140   (dolist (num '(1 2 3 4 5))
 141     (let ((newsym (intern (concat "muse-header-" (int-to-string num))))
 142           (docstring (concat
 143                       "Muse header face.  See "
 144                       "`muse-colors-autogen-headings' before changing it.")))
 145       ;; put in the proper group and give documentation
 146       (if later
 147           (unless (featurep 'xemacs)
 148             (muse-copy-face 'variable-pitch newsym)
 149             (set-face-attribute newsym nil :height (1+ (* 0.1 (- 5 num)))
 150                                 :weight 'bold))
 151         (if (featurep 'xemacs)
 152             (eval `(defface ,newsym
 153                      '((t (:size
 154                            ,(nth (1- num)
 155                                  '("24pt" "18pt" "14pt" "12pt" "11pt"))
 156                            :bold t)))
 157                      ,docstring
 158                      :group 'muse-colors))
 159           (eval `(defface ,newsym
 160                    '((t (:height ,(1+ (* 0.1 (- 5 num)))
 161                                  :inherit variable-pitch
 162                                  :weight bold)))
 163                    ,docstring
 164                    :group 'muse-colors)))))))
 165
 166 (progn (muse-make-faces-default))
 167
 168 (defun muse-make-faces (&optional frame)
 169   "Generate face definitions for headers based the user's preferences."
 170   (cond
 171    ((not muse-colors-autogen-headings)
 172     nil)
 173    ((eq muse-colors-autogen-headings t)
 174     (muse-make-faces-default t))
 175    (t
 176     (dolist (num '(1 2 3 4 5))
 177       (let ((newsym (intern (concat "muse-header-" (int-to-string num)))))
 178         ;; copy the desired face definition
 179         (muse-copy-face (nth (1- num) muse-colors-outline-faces-list)
 180                         newsym))))))
 181
 182 ;; after displaying the Emacs splash screen, the faces are wiped out,
 183 ;; so recover from that
 184 (add-hook 'window-setup-hook #'muse-make-faces)
 185 ;; ditto for when a new frame is created
 186 (when (boundp 'after-make-frame-functions)
 187   (add-hook 'after-make-frame-functions #'muse-make-faces))
 188
 189 (defface muse-link
 190   '((t :inherit link))
 191   "Face for Muse cross-references."
 192   :group 'muse-colors)
 193
 194 (defface muse-bad-link
 195   '((default :inherit link)
 196     (((class color) (background light))
 197      (:foreground "red" :underline "red" :bold t))
 198     (((class color) (background dark))
 199      (:foreground "coral" :underline "coral" :bold t))
 200     (t (:bold t)))
 201   "Face for bad Muse cross-references."
 202   :group 'muse-colors)
 203
 204 (defface muse-verbatim
 205   '((((class color) (background light))
 206      (:foreground "slate gray"))
 207     (((class color) (background dark))
 208      (:foreground "gray")))
 209   "Face for verbatim text."
 210   :group 'muse-colors)
 211
 212 (defface muse-emphasis-1
 213   '((t (:italic t)))
 214   "Face for italic emphasized text."
 215   :group 'muse-colors)
 216
 217 (defface muse-emphasis-2
 218   '((t (:bold t)))
 219   "Face for bold emphasized text."
 220   :group 'muse-colors)
 221
 222 (defface muse-emphasis-3
 223   '((t (:bold t :italic t)))
 224   "Face for bold italic emphasized text."
 225   :group 'muse-colors)
 226
 227 (muse-copy-face 'italic 'muse-emphasis-1)
 228 (muse-copy-face 'bold 'muse-emphasis-2)
 229 (muse-copy-face 'bold-italic 'muse-emphasis-3)
 230
 231 (defcustom muse-colors-buffer-hook nil
 232   "A hook run after a region is highlighted.
 233 Each function receives three arguments: BEG END VERBOSE.
 234 BEG and END mark the range being highlighted, and VERBOSE specifies
 235 whether progress messages should be displayed to the user."
 236   :type 'hook
 237   :group 'muse-colors)
 238
 239 (defvar muse-colors-highlighting-registry nil
 240   "The rules for highlighting Muse and Muse-derived buffers.
 241 This is automatically generated when using font-lock in Muse buffers.
 242
 243 This an alist of major-mode symbols to `muse-colors-rule' objects.")
 244
 245 (defun muse-colors-make-highlighting-struct ()
 246   (list nil nil nil))
 247 (defconst muse-colors-highlighting.regexp 0
 248   "Regexp matching each car of the markup of the current rule.")
 249 (defconst muse-colors-highlighting.vector 1
 250   "Vector of all characters that are part of the markup of the current rule.
 251 This is composed of the 2nd element of each markup entry.")
 252 (defconst muse-colors-highlighting.remaining 2
 253   "Expressions for highlighting a buffer which have no corresponding
 254 entry in the vector.")
 255
 256 (defsubst muse-colors-highlighting-entry (mode)
 257   "Return the highlighting rules for MODE."
 258   (assq mode muse-colors-highlighting-registry))
 259
 260 (defun muse-colors-find-highlighting (mode)
 261   "Return the highlighting rules to be used for MODE.
 262 If MODE does not have highlighting rules, check its parent modes."
 263   (let ((seen nil))
 264     (catch 'rules
 265       (while (and mode (not (memq mode seen)))
 266         (let ((entry (muse-colors-highlighting-entry mode)))
 267           (when entry (throw 'rules (cdr entry))))
 268         (setq seen (cons mode seen))
 269         (setq mode (get mode 'derived-mode-parent)))
 270       nil)))
 271
 272 (defun muse-colors-define-highlighting (mode markup)
 273   "Create or update the markup rules for MODE, using MARKUP.
 274
 275 See `muse-colors-markup' for an explanation of the format that MARKUP
 276 should take."
 277   (unless (and (symbolp mode) mode (consp markup))
 278     (error "Invalid arguments"))
 279   (let* ((highlighting-entry (muse-colors-highlighting-entry mode))
 280          (struct (cdr highlighting-entry))
 281          (regexp nil)
 282          (vector nil)
 283          (remaining nil))
 284     ;; Initialize struct
 285     (if struct
 286         (setq vector (nth muse-colors-highlighting.vector struct))
 287       (setq struct (muse-colors-make-highlighting-struct)))
 288     ;; Initialize vector
 289     (if vector
 290         (let ((i 0))
 291           (while (< i 128)
 292             (aset vector i nil)
 293             (setq i (1+ i))))
 294       (setq vector (make-vector 128 nil)))
 295     ;; Determine vector, regexp, remaining
 296     (let ((regexps nil)
 297           (rules nil))
 298       (dolist (rule markup)
 299         (let ((value (cond ((symbolp (car rule))
 300                             (symbol-value (car rule)))
 301                            ((stringp (car rule))
 302                             (car rule))
 303                            (t nil))))
 304           (when value
 305             (setq rules (cons rule rules))
 306             (setq regexps (cons value regexps)))))
 307       (setq regexps (nreverse regexps))
 308       (setq regexp (concat "\\(" (mapconcat #'identity regexps "\\|") "\\)"))
 309       (dolist (rule rules)
 310         (if (eq (nth 1 rule) t)
 311             (setq remaining (cons (cons (nth 0 rule) (nth 2 rule))
 312                                   remaining))
 313           (aset vector (nth 1 rule)
 314                 (cons (cons (nth 0 rule) (nth 2 rule))
 315                       (aref vector (nth 1 rule)))))))
 316     ;; Update the struct
 317     (setcar (nthcdr muse-colors-highlighting.regexp struct) regexp)
 318     (setcar (nthcdr muse-colors-highlighting.vector struct) vector)
 319     (setcar (nthcdr muse-colors-highlighting.remaining struct) remaining)
 320     ;; Update entry for mode in muse-colors-highlighting-registry
 321     (if highlighting-entry
 322         (setcdr highlighting-entry struct)
 323       (setq muse-colors-highlighting-registry
 324             (cons (cons mode struct)
 325                   muse-colors-highlighting-registry)))))
 326
 327 (defun muse-configure-highlighting (sym val)
 328   "Extract color markup information from VAL and set to SYM.
 329 This is usually called with `muse-colors-markup' as both arguments."
 330   (muse-colors-define-highlighting 'muse-mode val)
 331   (set sym val))
 332
 333 (defun muse-colors-emphasized ()
 334   "Color emphasized text and headings."
 335   ;; Here we need to check four different points - the start and end
 336   ;; of the leading *s, and the start and end of the trailing *s.  We
 337   ;; allow the outsides to be surrounded by whitespace or punctuation,
 338   ;; but no word characters, and the insides must not be surrounded by
 339   ;; whitespace or punctuation.  Thus the following are valid:
 340   ;;
 341   ;; " *foo bar* "
 342   ;; "**foo**,"
 343   ;; and the following is invalid:
 344   ;; "** testing **"
 345   (let* ((beg (match-beginning 0))
 346          (e1 (match-end 0))
 347          (leader (- e1 beg))
 348          b2 e2 multiline)
 349     (unless (or (eq (get-text-property beg 'invisible) 'muse)
 350                 (get-text-property beg 'muse-comment)
 351                 (get-text-property beg 'muse-directive))
 352       ;; check if it's a header
 353       (if (eq (char-after e1) ?\ )
 354           (when (or (= beg (point-min))
 355                     (eq (char-before beg) ?\n))
 356             (add-text-properties
 357              (muse-line-beginning-position) (muse-line-end-position)
 358              (list 'face (intern (concat "muse-header-"
 359                                          (int-to-string leader))))))
 360         ;; beginning of line or space or symbol
 361         (when (or (= beg (point-min))
 362                   (eq (char-syntax (char-before beg)) ?\ )
 363                   (memq (char-before beg)
 364                         '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
 365           (save-excursion
 366             (skip-chars-forward "^*<>\n" muse-colors-region-end)
 367             (when (eq (char-after) ?\n)
 368               (setq multiline t)
 369               (skip-chars-forward "^*<>" muse-colors-region-end))
 370             (setq b2 (point))
 371             (skip-chars-forward "*" muse-colors-region-end)
 372             (setq e2 (point))
 373             ;; Abort if space exists just before end
 374             ;; or bad leader
 375             ;; or no '*' at end
 376             ;; or word constituent follows
 377             (unless (or (> leader 5)
 378                         (not (eq leader (- e2 b2)))
 379                         (eq (char-syntax (char-before b2)) ?\ )
 380                         (not (eq (char-after b2) ?*))
 381                         (and (not (eobp))
 382                              (eq (char-syntax (char-after (1+ b2))) ?w)))
 383               (add-text-properties beg e1 '(invisible muse))
 384               (add-text-properties
 385                e1 b2 (list 'face (cond ((= leader 1) 'muse-emphasis-1)
 386                                        ((= leader 2) 'muse-emphasis-2)
 387                                        ((= leader 3) 'muse-emphasis-3))))
 388               (add-text-properties b2 e2 '(invisible muse))
 389               (when multiline
 390                 (add-text-properties
 391                  beg e2 '(font-lock-multiline t))))))))))
 392
 393 (defun muse-colors-underlined ()
 394   "Color underlined text."
 395   (let ((start (match-beginning 0))
 396         multiline)
 397     (unless (or (eq (get-text-property start 'invisible) 'muse)
 398                 (get-text-property start 'muse-comment)
 399                 (get-text-property start 'muse-directive))
 400       ;; beginning of line or space or symbol
 401       (when (or (= start (point-min))
 402                 (eq (char-syntax (char-before start)) ?\ )
 403                 (memq (char-before start)
 404                       '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
 405         (save-excursion
 406           (skip-chars-forward "^_<>\n" muse-colors-region-end)
 407           (when (eq (char-after) ?\n)
 408             (setq multiline t)
 409             (skip-chars-forward "^_<>" muse-colors-region-end))
 410           ;; Abort if space exists just before end
 411           ;; or no '_' at end
 412           ;; or word constituent follows
 413           (unless (or (eq (char-syntax (char-before (point))) ?\ )
 414                       (not (eq (char-after (point)) ?_))
 415                       (and (not (eobp))
 416                            (eq (char-syntax (char-after (1+ (point)))) ?w)))
 417             (add-text-properties start (1+ start) '(invisible muse))
 418             (add-text-properties (1+ start) (point) '(face underline))
 419             (add-text-properties (point)
 420                                  (min (1+ (point)) (point-max))
 421                                  '(invisible muse))
 422             (when multiline
 423               (add-text-properties
 424                start (min (1+ (point)) (point-max))
 425                '(font-lock-multiline t)))))))))
 426
 427 (defun muse-colors-verbatim ()
 428   "Render in teletype and suppress further parsing."
 429   (let ((start (match-beginning 0))
 430         multiline)
 431     (unless (or (eq (get-text-property start 'invisible) 'muse)
 432                 (get-text-property start 'muse-comment)
 433                 (get-text-property start 'muse-directive))
 434       ;; beginning of line or space or symbol
 435       (when (or (= start (point-min))
 436                 (eq (char-syntax (char-before start)) ?\ )
 437                 (memq (char-before start)
 438                       '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
 439         (let ((pos (point)))
 440           (skip-chars-forward "^=\n" muse-colors-region-end)
 441           (when (eq (char-after) ?\n)
 442             (setq multiline t)
 443             (skip-chars-forward "^=" muse-colors-region-end))
 444           ;; Abort if space exists just before end
 445           ;; or no '=' at end
 446           ;; or word constituent follows
 447           (unless (or (eq (char-syntax (char-before (point))) ?\ )
 448                       (not (eq (char-after (point)) ?=))
 449                       (and (not (eobp))
 450                            (eq (char-syntax (char-after (1+ (point)))) ?w)))
 451             (setq pos (min (1+ (point)) (point-max)))
 452             (add-text-properties start (1+ start) '(invisible muse))
 453             (add-text-properties (1+ start) (point) '(face muse-verbatim))
 454             (add-text-properties (point)
 455                                  (min (1+ (point)) (point-max))
 456                                  '(invisible muse))
 457             (when multiline
 458               (add-text-properties
 459                start (min (1+ (point)) (point-max))
 460                '(font-lock-multiline t))))
 461           (goto-char pos))))))
 462
 463 (defcustom muse-colors-markup
 464   `(;; make emphasized text appear emphasized
 465     ("\\*\\{1,5\\}" ?* muse-colors-emphasized)
 466
 467     ;; make underlined text appear underlined
 468     (,(concat "_[^" muse-regexp-blank "_\n]")
 469      ?_ muse-colors-underlined)
 470
 471     ("^#title " ?\# muse-colors-title)
 472
 473     (muse-explicit-link-regexp ?\[ muse-colors-explicit-link)
 474
 475     ;; render in teletype and suppress further parsing
 476     (,(concat "=[^" muse-regexp-blank "=\n]") ?= muse-colors-verbatim)
 477
 478     ;; highlight any markup tags encountered
 479     (muse-tag-regexp ?\< muse-colors-custom-tags)
 480
 481     ;; display comments
 482     (,(concat "^;[" muse-regexp-blank "]") ?\; muse-colors-comment)
 483
 484     ;; this has to come later since it doesn't have a special
 485     ;; character in the second cell
 486     (muse-url-regexp t muse-colors-implicit-link)
 487     )
 488   "Expressions to highlight an Emacs Muse buffer.
 489 These are arranged in a rather special fashion, so as to be as quick as
 490 possible.
 491
 492 Each element of the list is itself a list, of the form:
 493
 494   (LOCATE-REGEXP TEST-CHAR MATCH-FUNCTION)
 495
 496 LOCATE-REGEXP is a partial regexp, and should be the smallest possible
 497 regexp to differentiate this rule from other rules.  It may also be a
 498 symbol containing such a regexp.  The buffer region is scanned only
 499 once, and LOCATE-REGEXP indicates where the scanner should stop to
 500 look for highlighting possibilities.
 501
 502 TEST-CHAR is a char or t.  The character should match the beginning
 503 text matched by LOCATE-REGEXP.  These chars are used to build a vector
 504 for fast MATCH-FUNCTION calling.
 505
 506 MATCH-FUNCTION is the function called when a region has been
 507 identified.  It is responsible for adding the appropriate text
 508 properties to change the appearance of the buffer.
 509
 510 This markup is used to modify the appearance of the original text to
 511 make it look more like the published HTML would look (like making some
 512 markup text invisible, inlining images, etc).
 513
 514 font-lock is used to apply the markup rules, so that they can happen
 515 on a deferred basis.  They are not always accurate, but you can use
 516 \\[font-lock-fontifty-block] near the point of error to force
 517 fontification in that area."
 518   :type '(repeat
 519           (list :tag "Highlight rule"
 520                 (choice (regexp :tag "Locate regexp")
 521                         (symbol :tag "Regexp symbol"))
 522                 (choice (character :tag "Confirm character")
 523                         (const :tag "Default rule" t))
 524                 function))
 525   :set 'muse-configure-highlighting
 526   :group 'muse-colors)
 527
 528 ;; XEmacs users don't have `font-lock-multiline'.
 529 (unless (boundp 'font-lock-multiline)
 530   (defvar font-lock-multiline nil))
 531
 532 (defun muse-use-font-lock ()
 533   "Set up font-locking for Muse."
 534   (muse-add-to-invisibility-spec 'muse)
 535   (set (make-local-variable 'font-lock-multiline) 'undecided)
 536   (set (make-local-variable 'font-lock-defaults)
 537        `(nil t nil nil beginning-of-line
 538          (font-lock-fontify-region-function . muse-colors-region)
 539          (font-lock-unfontify-region-function
 540           . muse-unhighlight-region)))
 541   (set (make-local-variable 'font-lock-fontify-region-function)
 542        'muse-colors-region)
 543   (set (make-local-variable 'font-lock-unfontify-region-function)
 544        'muse-unhighlight-region)
 545   (muse-make-faces)
 546   (muse-colors-define-highlighting 'muse-mode muse-colors-markup)
 547   (font-lock-mode t))
 548
 549 (defun muse-colors-buffer ()
 550   "Re-highlight the entire Muse buffer."
 551   (interactive)
 552   (muse-colors-region (point-min) (point-max) t))
 553
 554 (defvar muse-colors-fontifying-p nil
 555   "Indicate whether Muse is fontifying the current buffer.")
 556 (make-variable-buffer-local 'muse-colors-fontifying-p)
 557
 558 (defvar muse-colors-delayed-commands nil
 559   "Commands to be run immediately after highlighting a region.
 560
 561 This is meant to accommodate highlighting <lisp> in #title
 562 directives after everything else.
 563
 564 It may be modified by Muse functions during highlighting, but not
 565 the user.")
 566 (make-variable-buffer-local 'muse-colors-delayed-commands)
 567
 568 (defun muse-colors-region (beg end &optional verbose)
 569   "Apply highlighting according to `muse-colors-markup'.
 570 Note that this function should NOT change the buffer, nor should any
 571 of the functions listed in `muse-colors-markup'."
 572   (let ((buffer-undo-list t)
 573         (inhibit-read-only t)
 574         (inhibit-point-motion-hooks t)
 575         (inhibit-modification-hooks t)
 576         (modified-p (buffer-modified-p))
 577         (muse-colors-fontifying-p t)
 578         (muse-colors-region-end (muse-line-end-position end))
 579         (muse-colors-delayed-commands nil)
 580         (highlighting (muse-colors-find-highlighting major-mode))
 581         regexp vector remaining
 582         deactivate-mark)
 583     (unless highlighting
 584       (error "No highlighting found for this mode"))
 585     (setq regexp (nth muse-colors-highlighting.regexp highlighting)
 586           vector (nth muse-colors-highlighting.vector highlighting)
 587           remaining (nth muse-colors-highlighting.remaining highlighting))
 588     (unwind-protect
 589         (save-excursion
 590           (save-restriction
 591             (widen)
 592             ;; check to see if we should expand the beg/end area for
 593             ;; proper multiline matches
 594             (when (and font-lock-multiline
 595                        (> beg (point-min))
 596                        (get-text-property (1- beg) 'font-lock-multiline))
 597               ;; We are just after or in a multiline match.
 598               (setq beg (or (previous-single-property-change
 599                              beg 'font-lock-multiline)
 600                             (point-min)))
 601               (goto-char beg)
 602               (setq beg (muse-line-beginning-position)))
 603             (when font-lock-multiline
 604               (setq end (or (text-property-any end (point-max)
 605                                                'font-lock-multiline nil)
 606                             (point-max))))
 607             (goto-char end)
 608             (setq end (muse-line-beginning-position 2))
 609             ;; Undo any fontification in the area.
 610             (font-lock-unfontify-region beg end)
 611             ;; And apply fontification based on `muse-colors-markup'
 612             (let ((len (float (- end beg)))
 613                   (case-fold-search nil)
 614                   markup-list)
 615               (goto-char beg)
 616               (while (and (< (point) end)
 617                           (re-search-forward regexp end t))
 618                 (if verbose
 619                     (message "Highlighting buffer...%d%%"
 620                              (* (/ (float (- (point) beg)) len) 100)))
 621                 (let ((ch (char-after (match-beginning 0))))
 622                   (when (< ch 128)
 623                     (setq markup-list (aref vector ch))))
 624                 (unless markup-list
 625                   (setq markup-list remaining))
 626                 (let ((prev (point)))
 627                   ;; backtrack and figure out which rule matched
 628                   (goto-char (match-beginning 0))
 629                   (catch 'done
 630                     (dolist (entry markup-list)
 631                       (let ((value (cond ((symbolp (car entry))
 632                                           (symbol-value (car entry)))
 633                                          ((stringp (car entry))
 634                                           (car entry))
 635                                          (t nil))))
 636                         (when (and (stringp value) (looking-at value))
 637                           (goto-char (match-end 0))
 638                           (when (cdr entry)
 639                             (funcall (cdr entry)))
 640                           (throw 'done t))))
 641                     ;; if no rule matched, which should never happen,
 642                     ;; return to previous position so that forward
 643                     ;; progress is ensured
 644                     (goto-char prev))))
 645               (dolist (command muse-colors-delayed-commands)
 646                 (apply (car command) (cdr command)))
 647               (run-hook-with-args 'muse-colors-buffer-hook
 648                                   beg end verbose)
 649               (if verbose (message "Highlighting buffer...done")))))
 650       (set-buffer-modified-p modified-p))))
 651
 652 (defcustom muse-colors-tags
 653   '(("example"  t nil nil muse-colors-example-tag)
 654     ("code"     t nil nil muse-colors-example-tag)
 655     ("verbatim" t nil nil muse-colors-literal-tag)
 656     ("lisp"     t t   nil muse-colors-lisp-tag)
 657     ("literal"  t nil nil muse-colors-literal-tag))
 658   "A list of tag specifications for specially highlighting text.
 659 XML-style tags are the best way to add custom highlighting to Muse.
 660 This is easily accomplished by customizing this list of markup tags.
 661
 662 For each entry, the name of the tag is given, whether it expects
 663 a closing tag and/or an optional set of attributes, whether it is
 664 nestable, and a function that performs whatever action is desired
 665 within the delimited region.
 666
 667 The function is called with three arguments, the beginning and
 668 end of the region surrounded by the tags. If properties are
 669 allowed, they are passed as a third argument in the form of an
 670 alist. The `end' argument to the function is the last character
 671 of the enclosed tag or region.
 672
 673 Functions should not modify the contents of the buffer."
 674   :type '(repeat (list (string :tag "Markup tag")
 675                        (boolean :tag "Expect closing tag" :value t)
 676                        (boolean :tag "Parse attributes" :value nil)
 677                        (boolean :tag "Nestable" :value nil)
 678                        function))
 679   :group 'muse-colors)
 680
 681 (defvar muse-colors-inhibit-tags-in-directives t
 682   "If non-nil, don't allow tags to be interpreted in directives.
 683 This is used to delay highlighting of <lisp> tags in #title until later.")
 684 (make-variable-buffer-local 'muse-colors-inhibit-tags-in-directives)
 685
 686 (defsubst muse-colors-tag-info (tagname &rest args)
 687   "Get tag info associated with TAGNAME, ignoring ARGS."
 688   (assoc tagname muse-colors-tags))
 689
 690 (defun muse-colors-custom-tags ()
 691   "Highlight `muse-colors-tags'."
 692   (let ((tag-info (muse-colors-tag-info (match-string 1))))
 693     (unless (or (not tag-info)
 694                 (get-text-property (match-beginning 0) 'muse-comment)
 695                 (and muse-colors-inhibit-tags-in-directives
 696                      (get-text-property (match-beginning 0) 'muse-directive)))
 697       (let ((closed-tag (match-string 3))
 698             (start (match-beginning 0))
 699             end attrs)
 700         (when (nth 2 tag-info)
 701           (let ((attrstr (match-string 2)))
 702             (while (and attrstr
 703                         (string-match (concat "\\([^"
 704                                               muse-regexp-blank
 705                                               "=\n]+\\)\\(=\""
 706                                               "\\([^\"]+\\)\"\\)?")
 707                                       attrstr))
 708               (let ((attr (cons (downcase
 709                                  (muse-match-string-no-properties 1 attrstr))
 710                                 (muse-match-string-no-properties 3 attrstr))))
 711                 (setq attrstr (replace-match "" t t attrstr))
 712                 (if attrs
 713                     (nconc attrs (list attr))
 714                   (setq attrs (list attr)))))))
 715         (if (and (cadr tag-info) (not closed-tag))
 716             (if (muse-goto-tag-end (car tag-info) (nth 3 tag-info))
 717                 (setq end (match-end 0))
 718               (setq tag-info nil)))
 719         (when tag-info
 720           (let ((args (list start end)))
 721             (if (nth 2 tag-info)
 722                 (nconc args (list attrs)))
 723             (apply (nth 4 tag-info) args)))))))
 724
 725 (defun muse-unhighlight-region (begin end &optional verbose)
 726   "Remove all visual highlights in the buffer (except font-lock)."
 727   (let ((buffer-undo-list t)
 728         (inhibit-read-only t)
 729         (inhibit-point-motion-hooks t)
 730         (inhibit-modification-hooks t)
 731         (modified-p (buffer-modified-p))
 732         deactivate-mark)
 733     (unwind-protect
 734         (remove-text-properties
 735          begin end '(face nil font-lock-multiline nil end-glyph nil
 736                           invisible nil intangible nil display nil
 737                           mouse-face nil keymap nil help-echo nil
 738                           muse-link nil muse-directive nil muse-comment nil
 739                           muse-no-implicit-link nil muse-no-flyspell nil))
 740       (set-buffer-modified-p modified-p))))
 741
 742 (defun muse-colors-example-tag (beg end)
 743   "Strip properties and colorize with `muse-verbatim'."
 744   (muse-unhighlight-region beg end)
 745   (let ((multi (save-excursion
 746                  (goto-char beg)
 747                  (forward-line 1)
 748                  (> end (point)))))
 749     (add-text-properties beg end `(face muse-verbatim
 750                                    font-lock-multiline ,multi))))
 751
 752 (defun muse-colors-literal-tag (beg end)
 753   "Strip properties and mark as literal."
 754   (muse-unhighlight-region beg end)
 755   (let ((multi (save-excursion
 756                  (goto-char beg)
 757                  (forward-line 1)
 758                  (> end (point)))))
 759     (add-text-properties beg end `(font-lock-multiline ,multi))))
 760
 761 (defun muse-colors-lisp-tag (beg end attrs)
 762   "Color the region enclosed by a <lisp> tag."
 763   (if (not muse-colors-evaluate-lisp-tags)
 764       (muse-colors-literal-tag beg end)
 765     (muse-unhighlight-region beg end)
 766     (let (beg-lisp end-lisp)
 767       (save-match-data
 768         (goto-char beg)
 769         (setq beg-lisp (and (looking-at "<[^>]+>")
 770                             (match-end 0)))
 771         (goto-char end)
 772         (setq end-lisp (and (muse-looking-back "</[^>]+>")
 773                             (match-beginning 0))))
 774       (add-text-properties
 775        beg end
 776        (list 'font-lock-multiline t
 777              'display (muse-eval-lisp
 778                        (concat
 779                         "(progn "
 780                         (buffer-substring-no-properties beg-lisp end-lisp)
 781                         ")"))
 782              'intangible t)))))
 783
 784 (defvar muse-mode-local-map
 785   (let ((map (make-sparse-keymap)))
 786     (define-key map [return] 'muse-follow-name-at-point)
 787     (define-key map [(control ?m)] 'muse-follow-name-at-point)
 788     (define-key map [(shift return)] 'muse-follow-name-at-point-other-window)
 789     (if (featurep 'xemacs)
 790         (progn
 791           (define-key map [(button2)] 'muse-follow-name-at-mouse)
 792           (define-key map [(shift button2)]
 793             'muse-follow-name-at-mouse-other-window))
 794       (define-key map [(shift control ?m)]
 795         'muse-follow-name-at-point-other-window)
 796       (define-key map [mouse-2] 'muse-follow-name-at-mouse)
 797       (define-key map [(shift mouse-2)]
 798         'muse-follow-name-at-mouse-other-window)
 799       (unless (eq emacs-major-version 21)
 800         (set-keymap-parent map muse-mode-map)))
 801     map)
 802   "Local keymap used by Muse while on a link.")
 803
 804 (defvar muse-keymap-property
 805   (if (or (featurep 'xemacs)
 806           (>= emacs-major-version 21))
 807       'keymap
 808     'local-map)
 809   "The name of the keymap or local-map property.")
 810
 811 (defsubst muse-link-properties (help-str &optional face)
 812   "Determine text properties to use for a link."
 813   (append (if face
 814               (list 'face face 'mouse-face 'highlight 'muse-link t)
 815             (list 'invisible 'muse 'intangible t))
 816           (list 'help-echo help-str 'rear-nonsticky t
 817                 muse-keymap-property muse-mode-local-map)))
 818
 819 (defun muse-link-face (link-name &optional explicit)
 820   "Return the type of LINK-NAME as a face symbol.
 821 For EXPLICIT links, this is either a normal link or a bad-link
 822 face.  For implicit links, it is either colored normally or
 823 ignored."
 824   (save-match-data
 825     (let ((link (if explicit
 826                     (muse-handle-explicit-link link-name)
 827                   (muse-handle-implicit-link link-name))))
 828       (when link
 829         (cond ((string-match muse-url-regexp link)
 830                'muse-link)
 831               ((muse-file-remote-p link)
 832                'muse-link)
 833               ((string-match muse-file-regexp link)
 834                (when (string-match "/[^/]+#[^#./]+\\'" link)
 835                  ;; strip anchor from the end of a path
 836                  (setq link (substring link 0 (match-beginning 0))))
 837                (if (file-exists-p link)
 838                    'muse-link
 839                  'muse-bad-link))
 840               ((not (featurep 'muse-project))
 841                'muse-link)
 842               (t
 843                (if (string-match "#" link)
 844                    (setq link (substring link 0 (match-beginning 0))))
 845                (if (or (and (muse-project-of-file)
 846                             (muse-project-page-file
 847                              link muse-current-project t))
 848                        (file-exists-p link))
 849                    'muse-link
 850                  'muse-bad-link)))))))
 851
 852 (defun muse-colors-use-publishing-directory (link)
 853   "Make LINK relative to the directory where we will publish the
 854 current file."
 855   (let ((style (car (muse-project-applicable-styles
 856                      link (cddr (muse-project)))))
 857         path)
 858     (when (and style
 859                (setq path (muse-style-element :path style)))
 860       (expand-file-name link path))))
 861
 862 (defun muse-colors-resolve-image-file (link)
 863   "Determine if we can create images and see if the link is an image
 864 file."
 865   (save-match-data
 866     (and (or (fboundp 'create-image)
 867              (fboundp 'make-glyph))
 868          (not (string-match "\\`[uU][rR][lL]:" link))
 869          (string-match muse-image-regexp link))))
 870
 871 (defun muse-make-file-glyph (filename)
 872   "Given a file name, return a newly-created image glyph.
 873 This is a hack for supporting inline images in XEmacs."
 874   (let ((case-fold-search nil))
 875     ;; Scan filename to determine image type
 876     (when (fboundp 'make-glyph)
 877       (save-match-data
 878         (cond ((string-match "jpe?g" filename)
 879                (make-glyph (vector 'jpeg :file filename) 'buffer))
 880               ((string-match "gif" filename)
 881                (make-glyph (vector 'gif :file filename) 'buffer))
 882               ((string-match "png" filename)
 883                (make-glyph (vector 'png :file filename) 'buffer)))))))
 884
 885 (defun muse-colors-insert-image (link beg end invis-props)
 886   "Create an image using create-image or make-glyph and insert it
 887 in place of an image link defined by BEG and END."
 888   (setq link (expand-file-name link))
 889   (let ((image-file (cond
 890                      ((eq muse-colors-inline-image-method 'default-directory)
 891                       link)
 892                      ((functionp muse-colors-inline-image-method)
 893                       (funcall muse-colors-inline-image-method link))))
 894         glyph)
 895     (when (stringp image-file)
 896       (if (fboundp 'create-image)
 897           ;; use create-image and display property
 898           (let ((display-stuff (condition-case nil
 899                                    (create-image image-file)
 900                                  (error nil))))
 901             (when display-stuff
 902               (add-text-properties beg end (list 'display display-stuff))))
 903         ;; use make-glyph and invisible property
 904         (and (setq glyph (muse-make-file-glyph image-file))
 905              (progn
 906                (add-text-properties beg end invis-props)
 907                (add-text-properties beg end (list
 908                                              'end-glyph glyph
 909                                              'help-echo link))))))))
 910
 911 (defun muse-colors-explicit-link ()
 912   "Color explicit links."
 913   (when (and (eq ?\[ (char-after (match-beginning 0)))
 914              (not (get-text-property (match-beginning 0) 'muse-comment))
 915              (not (get-text-property (match-beginning 0) 'muse-directive)))
 916     ;; remove flyspell overlays
 917     (when (fboundp 'flyspell-unhighlight-at)
 918       (let ((cur (match-beginning 0)))
 919         (while (> (match-end 0) cur)
 920           (flyspell-unhighlight-at cur)
 921           (setq cur (1+ cur)))))
 922     (let* ((unesc-link (muse-get-link))
 923            (unesc-desc (muse-get-link-desc))
 924            (link (muse-link-unescape unesc-link))
 925            (desc (muse-link-unescape unesc-desc))
 926            (props (muse-link-properties desc (muse-link-face link t)))
 927            (invis-props (append props (muse-link-properties desc))))
 928       ;; see if we should try and inline an image
 929       (if (and muse-colors-inline-images
 930                (or (muse-colors-resolve-image-file link)
 931                    (and desc
 932                         (muse-colors-resolve-image-file desc)
 933                         (setq link desc))))
 934           ;; we found an image, so inline it
 935           (muse-colors-insert-image
 936            link
 937            (match-beginning 0) (match-end 0) invis-props)
 938         (if desc
 939             (progn
 940               ;; we put the normal face properties on the invisible
 941               ;; portion too, since emacs sometimes will position
 942               ;; the cursor on an intangible character
 943               (add-text-properties (match-beginning 0)
 944                                    (match-beginning 2) invis-props)
 945               (add-text-properties (match-beginning 2) (match-end 2) props)
 946               (add-text-properties (match-end 2) (match-end 0) invis-props)
 947               ;; in case specials were escaped, cause the unescaped
 948               ;; text to be displayed
 949               (unless (string= desc unesc-desc)
 950                 (add-text-properties (match-beginning 2) (match-end 2)
 951                                      (list 'display desc))))
 952           (add-text-properties (match-beginning 0)
 953                                (match-beginning 1) invis-props)
 954           (add-text-properties (match-beginning 1) (match-end 0) props)
 955           (add-text-properties (match-end 1) (match-end 0) invis-props)
 956           (unless (string= link unesc-link)
 957             (add-text-properties (match-beginning 1) (match-end 1)
 958                                  (list 'display link))))
 959         (goto-char (match-end 0))
 960         (add-text-properties
 961          (match-beginning 0) (match-end 0)
 962          (muse-link-properties (muse-match-string-no-properties 0)
 963                                (muse-link-face link t)))))))
 964
 965 (defun muse-colors-implicit-link ()
 966   "Color implicit links."
 967   (unless (or (eq (get-text-property (match-beginning 0) 'invisible) 'muse)
 968               (get-text-property (match-beginning 0) 'muse-comment)
 969               (get-text-property (match-beginning 0) 'muse-directive)
 970               (get-text-property (match-beginning 0) 'muse-no-implicit-link)
 971               (eq (char-before (match-beginning 0)) ?\")
 972               (eq (char-after (match-end 0)) ?\"))
 973     ;; remove flyspell overlays
 974     (when (fboundp 'flyspell-unhighlight-at)
 975       (let ((cur (match-beginning 0)))
 976         (while (> (match-end 0) cur)
 977           (flyspell-unhighlight-at cur)
 978           (setq cur (1+ cur)))))
 979     ;; colorize link
 980     (let ((link (muse-match-string-no-properties 0))
 981           (face (muse-link-face (match-string 0))))
 982       (when face
 983         (add-text-properties (match-beginning 0) (match-end 0)
 984                              (muse-link-properties
 985                               (muse-match-string-no-properties 0) face))))))
 986
 987 (defun muse-colors-title ()
 988   "Color #title directives."
 989   (let ((beg (+ 7 (match-beginning 0))))
 990     (add-text-properties beg (muse-line-end-position) '(muse-directive t))
 991     ;; colorize <lisp> tags in #title after other <lisp> tags have had a
 992     ;; chance to run, so that we can have behavior that is consistent
 993     ;; with how the document is published
 994     (setq muse-colors-delayed-commands
 995           (cons (list 'muse-colors-title-lisp beg (muse-line-end-position))
 996                 muse-colors-delayed-commands))))
 997
 998 (defun muse-colors-title-lisp (beg end)
 999   "Called after other highlighting is done for a region in order to handle
1000 <lisp> tags that exist in #title directives."
1001   (save-restriction
1002     (narrow-to-region beg end)
1003     (goto-char (point-min))
1004     (let ((muse-colors-inhibit-tags-in-directives nil)
1005           (muse-colors-tags '(("lisp" t t nil muse-colors-lisp-tag))))
1006       (while (re-search-forward muse-tag-regexp nil t)
1007         (muse-colors-custom-tags))))
1008   (add-text-properties beg end '(face muse-header-1)))
1009
1010 (defun muse-colors-comment ()
1011   "Color comments."
1012   (add-text-properties (match-beginning 0) (muse-line-end-position)
1013                        (list 'face 'font-lock-comment-face
1014                              'muse-comment t)))
1015
1016
1017 (provide 'muse-colors)
1018
1019 ;;; muse-colors.el ends here