lisp/muse-colors.el

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