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