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