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