lisp/muse-colors.el

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