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