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               (while (and (< (point) end)
 427                           (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     ("code" t nil muse-colors-literal-tag)
 444     ("lisp" t nil muse-colors-literal-tag)
 445     ("literal" t nil muse-colors-literal-tag))
 446   "A list of tag specifications for specially highlighting text.
 447 XML-style tags are the best way to add custom highlighting to Muse.
 448 This is easily accomplished by customizing this list of markup tags.
 449
 450 For each entry, the name of the tag is given, whether it expects
 451 a closing tag and/or an optional set of attributes, and a
 452 function that performs whatever action is desired within the
 453 delimited region.
 454
 455 The function is called with three arguments, the beginning and
 456 end of the region surrounded by the tags. If properties are
 457 allowed, they are passed as a third argument in the form of an
 458 alist. The `end' argument to the function is the last character
 459 of the enclosed tag or region.
 460
 461 Functions should not modify the contents of the buffer."
 462   :type '(repeat (list (string :tag "Markup tag")
 463                        (boolean :tag "Expect closing tag" :value t)
 464                        (boolean :tag "Parse attributes" :value nil)
 465                        function))
 466   :group 'muse-colors)
 467
 468 (defsubst muse-colors-tag-info (tagname &rest args)
 469   (assoc tagname muse-colors-tags))
 470
 471 (defun muse-colors-custom-tags ()
 472   "Highlight `muse-colors-tags'."
 473   (let ((tag-info (muse-colors-tag-info (match-string 4))))
 474     (when tag-info
 475       (let ((closed-tag (match-string 3))
 476             (start (match-beginning 0))
 477             end attrs)
 478         (when (nth 2 tag-info)
 479           (let ((attrstr (match-string 2)))
 480             (while (and attrstr
 481                         (string-match (concat "\\([^"
 482                                               muse-regexp-space
 483                                               "=]+\\)\\(=\""
 484                                               "\\([^\"]+\\)\"\\)?")
 485                                       attrstr))
 486               (let ((attr (cons (downcase
 487                                  (muse-match-string-no-properties 1 attrstr))
 488                                 (muse-match-string-no-properties 3 attrstr))))
 489                 (setq attrstr (replace-match "" t t attrstr))
 490                 (if attrs
 491                     (nconc attrs (list attr))
 492                   (setq attrs (list attr)))))))
 493         (if (and (cadr tag-info) (not closed-tag))
 494             (if (search-forward (concat "</" (car tag-info) ">") nil t)
 495                 (setq end (match-end 0))
 496               (setq tag-info nil)))
 497         (when tag-info
 498           (let ((args (list start end)))
 499             (if (nth 2 tag-info)
 500                 (nconc args (list attrs)))
 501             (apply (nth 3 tag-info) args)))))))
 502
 503 (defun muse-unhighlight-region (begin end &optional verbose)
 504   "Remove all visual highlights in the buffer (except font-lock)."
 505   (let ((buffer-undo-list t)
 506         (inhibit-read-only t)
 507         (inhibit-point-motion-hooks t)
 508         (inhibit-modification-hooks t)
 509         (modified-p (buffer-modified-p))
 510         deactivate-mark)
 511     (unwind-protect
 512         (remove-text-properties
 513          begin end '(face nil font-lock-multiline nil
 514                           invisible nil intangible nil display nil
 515                           mouse-face nil keymap nil help-echo nil))
 516       (set-buffer-modified-p modified-p))))
 517
 518 (defun muse-colors-example-tag (beg end)
 519   "Strip properties and colorize with `muse-verbatim-face'."
 520   (muse-unhighlight-region beg end)
 521   (let ((multi (save-excursion
 522                  (goto-char beg)
 523                  (forward-line 1)
 524                  (> end (point)))))
 525     (add-text-properties beg end `(face muse-verbatim-face
 526                                    font-lock-multiline ,multi))))
 527
 528 (defun muse-colors-literal-tag (beg end)
 529   "Strip properties and mark as literal."
 530   (muse-unhighlight-region beg end)
 531   (let ((multi (save-excursion
 532                  (goto-char beg)
 533                  (forward-line 1)
 534                  (> end (point)))))
 535     (add-text-properties beg end `(font-lock-multiline ,multi))))
 536
 537 (defvar muse-mode-local-map
 538   (let ((map (make-sparse-keymap)))
 539     (define-key map [return] 'muse-follow-name-at-point)
 540     (define-key map [(control ?m)] 'muse-follow-name-at-point)
 541     (define-key map [(shift return)] 'muse-follow-name-at-point-other-window)
 542     (if (featurep 'xemacs)
 543         (progn
 544           (define-key map [(button2)] 'muse-follow-name-at-mouse)
 545           (define-key map [(shift button2)]
 546             'muse-follow-name-at-mouse-other-window))
 547       (define-key map [(shift control ?m)]
 548         'muse-follow-name-at-point-other-window)
 549       (define-key map [mouse-2] 'muse-follow-name-at-mouse)
 550       (define-key map [(shift mouse-2)]
 551         'muse-follow-name-at-mouse-other-window)
 552       (unless (eq emacs-major-version 21)
 553         (set-keymap-parent map muse-mode-map)))
 554     map)
 555   "Local keymap used by Muse while on a link.")
 556
 557 (defvar muse-keymap-property
 558   (if (or (featurep 'xemacs)
 559           (>= emacs-major-version 21))
 560       'keymap
 561     'local-map))
 562
 563 (defsubst muse-link-properties (help-str &optional face)
 564   (append (if face
 565               (list 'face face 'rear-nonsticky t
 566                     muse-keymap-property muse-mode-local-map)
 567             (list 'invisible 'muse 'intangible t 'rear-nonsticky t
 568                   muse-keymap-property muse-mode-local-map))
 569           (list 'mouse-face 'highlight
 570                 'help-echo help-str
 571                 muse-keymap-property muse-mode-local-map)))
 572
 573 (defun muse-link-face (link-name &optional explicit)
 574   "Return the type of LINK-NAME as a face symbol.
 575 For EXPLICIT links, this is either a normal link or a bad-link
 576 face.  For implicit links, it is either colored normally or
 577 ignored."
 578   (save-match-data
 579     (let ((link (if explicit
 580                     (muse-handle-explicit-link link-name)
 581                   (muse-handle-implicit-link link-name))))
 582       (when link
 583         (if (or (not explicit)
 584                 (string-match muse-file-regexp link)
 585                 (string-match muse-url-regexp link))
 586             'muse-link-face
 587           (if (not (featurep 'muse-project))
 588               'muse-link-face
 589             (if (string-match "#" link)
 590                 (setq link (substring link 0 (match-beginning 0))))
 591             (if (or (and (muse-project-of-file)
 592                          (muse-project-page-file link muse-current-project t))
 593                     (file-exists-p link))
 594                 'muse-link-face
 595               (when explicit
 596                 'muse-bad-link-face))))))))
 597
 598 (defun muse-colors-explicit-link ()
 599   "Color explicit links."
 600   (when (eq ?\[ (char-after (match-beginning 0)))
 601     ;; remove flyspell overlays
 602     (when (fboundp 'flyspell-unhighlight-at)
 603       (let ((cur (match-beginning 0)))
 604         (while (> (match-end 0) cur)
 605           (flyspell-unhighlight-at cur)
 606           (setq cur (1+ cur)))))
 607     (save-excursion
 608       (goto-char (match-beginning 0))
 609       (looking-at muse-explicit-link-regexp))
 610     (let* ((link (muse-match-string-no-properties 1))
 611            (desc (muse-match-string-no-properties 2))
 612            (props (muse-link-properties
 613                    desc (muse-link-face link t)))
 614            (invis-props (append props (muse-link-properties desc))))
 615       (if desc
 616           (progn
 617             ;; we put the normal face properties on the invisible
 618             ;; portion too, since emacs sometimes will position
 619             ;; the cursor on an intangible character
 620             (add-text-properties (match-beginning 0)
 621                                  (match-beginning 2) invis-props)
 622             (add-text-properties (match-beginning 2) (match-end 2) props)
 623             (add-text-properties (match-end 2) (match-end 0) invis-props))
 624         (add-text-properties (match-beginning 0)
 625                              (match-beginning 1) invis-props)
 626         (add-text-properties (match-beginning 1) (match-end 0) props)
 627         (add-text-properties (match-end 1) (match-end 0) invis-props))
 628       (goto-char (match-end 0))
 629       (add-text-properties
 630        (match-beginning 0) (match-end 0)
 631        (muse-link-properties (muse-match-string-no-properties 0)
 632                              (muse-link-face link t)))
 633       (goto-char (match-end 0)))))
 634
 635 (defun muse-colors-implicit-link ()
 636   "Color implicit links."
 637   ;; remove flyspell overlays
 638   (when (fboundp 'flyspell-unhighlight-at)
 639     (let ((cur (match-beginning 0)))
 640       (while (> (match-end 0) cur)
 641         (flyspell-unhighlight-at cur)
 642         (setq cur (1+ cur)))))
 643   (unless (or (eq (get-text-property (match-beginning 0) 'invisible) 'muse)
 644               (eq (char-before (match-beginning 0)) ?\")
 645               (eq (char-after (match-end 0)) ?\"))
 646     (let ((link (muse-match-string-no-properties 1))
 647           (face (muse-link-face (match-string 1))))
 648       (when face
 649         (add-text-properties (match-beginning 1) (match-end 0)
 650                              (muse-link-properties
 651                               (muse-match-string-no-properties 1) face))))))
 652
 653 (defun muse-colors-title ()
 654   (add-text-properties (+ 7 (match-beginning 0))
 655                        (muse-line-end-position)
 656                        '(face muse-header-1)))
 657
 658 (provide 'muse-colors)
 659
 660 ;;; muse-colors.el ends here