lisp/muse-colors.el

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