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                         (and (not (eobp))
 228                              (eq (char-syntax (char-after (1+ b2))) ?w)))
 229               (add-text-properties beg e1 '(invisible muse))
 230               (add-text-properties
 231                e1 b2 (list 'face (cond ((= leader 1) 'italic)
 232                                        ((= leader 2) 'bold)
 233                                        ((= leader 3) 'bold-italic))))
 234               (add-text-properties b2 e2 '(invisible muse))
 235               (when multiline
 236                 (add-text-properties
 237                  beg e2 '(font-lock-multiline t))))))))))
 238
 239 (defun muse-colors-underlined ()
 240   (let ((start (match-beginning 0))
 241         multiline)
 242     (unless (eq (get-text-property start 'invisible) 'muse)
 243       ;; beginning of line or space or symbol
 244       (when (or (= start (point-min))
 245                 (eq (char-syntax (char-before start)) ?\ )
 246                 (memq (char-before start)
 247                       '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
 248         (save-excursion
 249           (skip-chars-forward "^_<>\n" end)
 250           (when (eq (char-after) ?\n)
 251             (setq multiline t)
 252             (skip-chars-forward "^_<>" end))
 253           ;; Abort if space exists just before end
 254           ;; or no '_' at end
 255           ;; or word constituent follows
 256           (unless (or (eq (char-syntax (char-before (point))) ?\ )
 257                       (not (eq (char-after (point)) ?_))
 258                       (and (not (eobp))
 259                            (eq (char-syntax (char-after (1+ (point)))) ?w)))
 260             (add-text-properties start (1+ start) '(invisible muse))
 261             (add-text-properties (1+ start) (point) '(face underline))
 262             (add-text-properties (point)
 263                                  (min (1+ (point)) (point-max))
 264                                  '(invisible muse))
 265             (when multiline
 266               (add-text-properties
 267                start (min (1+ (point)) (point-max))
 268                '(font-lock-multiline t)))))))))
 269
 270 (defun muse-colors-verbatim ()
 271   (let ((start (match-beginning 0))
 272         multiline)
 273     (unless (eq (get-text-property start 'invisible) 'muse)
 274       ;; beginning of line or space or symbol
 275       (when (or (= start (point-min))
 276                 (eq (char-syntax (char-before start)) ?\ )
 277                 (memq (char-before start)
 278                       '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
 279         (save-excursion
 280           (skip-chars-forward "^=\n" end)
 281           (when (eq (char-after) ?\n)
 282             (setq multiline t)
 283             (skip-chars-forward "^=" end))
 284           ;; Abort if space exists just before end
 285           ;; or no '=' at end
 286           ;; or word constituent follows
 287           (unless (or (eq (char-syntax (char-before (point))) ?\ )
 288                       (not (eq (char-after (point)) ?=))
 289                       (and (not (eobp))
 290                            (eq (char-syntax (char-after (1+ (point)))) ?w)))
 291             (add-text-properties start (1+ start) '(invisible muse))
 292             (add-text-properties (1+ start) (point) '(face muse-verbatim-face))
 293             (add-text-properties (point)
 294                                  (min (1+ (point)) (point-max))
 295                                  '(invisible muse))
 296             (when multiline
 297               (add-text-properties
 298                start (min (1+ (point)) (point-max))
 299                '(font-lock-multiline t)))))))))
 300
 301 (defcustom muse-colors-markup
 302   `(;; make emphasized text appear emphasized
 303     ("\\*\\{1,5\\}" ?* muse-colors-emphasized)
 304
 305     ;; make underlined text appear underlined
 306     (,(concat "_[^" muse-regexp-space "_]")
 307      ?_ muse-colors-underlined)
 308
 309     ("^#title" ?\# muse-colors-title)
 310
 311     (muse-explicit-link-regexp ?\[ muse-colors-explicit-link)
 312
 313     ;; render in teletype and suppress further parsing
 314     (,(concat "=[^" muse-regexp-space "=]") ?= muse-colors-verbatim)
 315
 316     ;; highlight any markup tags encountered
 317     (muse-tag-regexp ?\< muse-colors-custom-tags)
 318
 319     ;; this has to come later since it doesn't have a special
 320     ;; character in the second cell
 321     (muse-url-regexp t muse-colors-implicit-link)
 322     )
 323   "Expressions to highlight an Emacs Muse buffer.
 324 These are arranged in a rather special fashion, so as to be as quick as
 325 possible.
 326
 327 Each element of the list is itself a list, of the form:
 328
 329   (LOCATE-REGEXP TEST-CHAR MATCH-FUNCTION)
 330
 331 LOCATE-REGEXP is a partial regexp, and should be the smallest possible
 332 regexp to differentiate this rule from other rules.  It may also be a
 333 symbol containing such a regexp.  The buffer region is scanned only
 334 once, and LOCATE-REGEXP indicates where the scanner should stop to
 335 look for highlighting possibilities.
 336
 337 TEST-CHAR is a char or t.  The character should match the beginning
 338 text matched by LOCATE-REGEXP.  These chars are used to build a vector
 339 for fast MATCH-FUNCTION calling.
 340
 341 MATCH-FUNCTION is the function called when a region has been
 342 identified.  It is responsible for adding the appropriate text
 343 properties to change the appearance of the buffer.
 344
 345 This markup is used to modify the appearance of the original text to
 346 make it look more like the published HTML would look (like making some
 347 markup text invisible, inlining images, etc).
 348
 349 font-lock is used to apply the markup rules, so that they can happen
 350 on a deferred basis.  They are not always accurate, but you can use
 351 \\[font-lock-fontifty-block] near the point of error to force
 352 fontification in that area.
 353
 354 Lastly, none of the regexp should contain grouping elements that will
 355 affect the match data results."
 356   :type '(repeat
 357           (list :tag "Highlight rule"
 358                 (choice (regexp :tag "Locate regexp")
 359                         (symbol :tag "Regexp symbol"))
 360                 (choice (character :tag "Confirm character")
 361                         (const :tag "Default rule" t))
 362                 function))
 363   :set 'muse-configure-highlighting
 364   :group 'muse-colors)
 365
 366 ;; XEmacs users don't have `font-lock-multiline'.
 367 (unless (boundp 'font-lock-multiline)
 368   (defvar font-lock-multiline nil))
 369
 370 (defun muse-use-font-lock ()
 371   (muse-add-to-invisibility-spec 'muse)
 372   (set (make-local-variable 'font-lock-multiline) 'undecided)
 373   (set (make-local-variable 'font-lock-defaults)
 374        `(nil t nil nil 'beginning-of-line
 375          (font-lock-fontify-region-function . muse-colors-region)
 376          (font-lock-unfontify-region-function
 377           . muse-unhighlight-region)))
 378   (set (make-local-variable 'font-lock-fontify-region-function)
 379        'muse-colors-region)
 380   (set (make-local-variable 'font-lock-unfontify-region-function)
 381        'muse-unhighlight-region)
 382   (muse-make-faces)
 383   (muse-configure-highlighting 'muse-colors-markup muse-colors-markup)
 384   (font-lock-mode t))
 385
 386 (defun muse-colors-buffer ()
 387   "Re-highlight the entire Muse buffer."
 388   (interactive)
 389   (muse-colors-region (point-min) (point-max) t))
 390
 391 (defun muse-colors-region (beg end &optional verbose)
 392   "Apply highlighting according to `muse-colors-markup'.
 393 Note that this function should NOT change the buffer, nor should any
 394 of the functions listed in `muse-colors-markup'."
 395   (let ((buffer-undo-list t)
 396         (inhibit-read-only t)
 397         (inhibit-point-motion-hooks t)
 398         (inhibit-modification-hooks t)
 399         (modified-p (buffer-modified-p))
 400         deactivate-mark)
 401     (unwind-protect
 402         (save-excursion
 403           (save-restriction
 404             (widen)
 405             ;; check to see if we should expand the beg/end area for
 406             ;; proper multiline matches
 407             (when (and font-lock-multiline
 408                        (> beg (point-min))
 409                        (get-text-property (1- beg) 'font-lock-multiline))
 410               ;; We are just after or in a multiline match.
 411               (setq beg (or (previous-single-property-change
 412                              beg 'font-lock-multiline)
 413                             (point-min)))
 414               (goto-char beg)
 415               (setq beg (muse-line-beginning-position)))
 416             (when font-lock-multiline
 417               (setq end (or (text-property-any end (point-max)
 418                                                'font-lock-multiline nil)
 419                             (point-max))))
 420             (goto-char end)
 421             (setq end (muse-line-beginning-position 2))
 422             ;; Undo any fontification in the area.
 423             (font-lock-unfontify-region beg end)
 424             ;; And apply fontification based on `muse-colors-markup'
 425             (let ((len (float (- end beg)))
 426                   (case-fold-search nil)
 427                   markup-func)
 428               (goto-char beg)
 429               (while (and (< (point) end)
 430                           (re-search-forward muse-colors-regexp end t))
 431                 (if verbose
 432                     (message "Highlighting buffer...%d%%"
 433                              (* (/ (float (- (point) beg)) len) 100)))
 434                 (setq markup-func
 435                       (aref muse-colors-vector
 436                             (char-after (match-beginning 0))))
 437                 (when markup-func (funcall markup-func)))
 438               (run-hook-with-args 'muse-colors-buffer-hook
 439                                   beg end verbose)
 440               (if verbose (message "Highlighting buffer...done")))))
 441       (set-buffer-modified-p modified-p))))
 442
 443 (defcustom muse-colors-tags
 444   '(("example" t nil muse-colors-example-tag)
 445     ("verbatim" t nil muse-colors-example-tag)
 446     ("code" t nil muse-colors-literal-tag)
 447     ("lisp" t nil muse-colors-literal-tag)
 448     ("literal" t nil muse-colors-literal-tag))
 449   "A list of tag specifications for specially highlighting text.
 450 XML-style tags are the best way to add custom highlighting to Muse.
 451 This is easily accomplished by customizing this list of markup tags.
 452
 453 For each entry, the name of the tag is given, whether it expects
 454 a closing tag and/or an optional set of attributes, and a
 455 function that performs whatever action is desired within the
 456 delimited region.
 457
 458 The function is called with three arguments, the beginning and
 459 end of the region surrounded by the tags. If properties are
 460 allowed, they are passed as a third argument in the form of an
 461 alist. The `end' argument to the function is the last character
 462 of the enclosed tag or region.
 463
 464 Functions should not modify the contents of the buffer."
 465   :type '(repeat (list (string :tag "Markup tag")
 466                        (boolean :tag "Expect closing tag" :value t)
 467                        (boolean :tag "Parse attributes" :value nil)
 468                        function))
 469   :group 'muse-colors)
 470
 471 (defsubst muse-colors-tag-info (tagname &rest args)
 472   (assoc tagname muse-colors-tags))
 473
 474 (defun muse-colors-custom-tags ()
 475   "Highlight `muse-colors-tags'."
 476   (let ((tag-info (muse-colors-tag-info (match-string 4))))
 477     (when tag-info
 478       (let ((closed-tag (match-string 3))
 479             (start (match-beginning 0))
 480             end attrs)
 481         (when (nth 2 tag-info)
 482           (let ((attrstr (match-string 2)))
 483             (while (and attrstr
 484                         (string-match (concat "\\([^"
 485                                               muse-regexp-space
 486                                               "=]+\\)\\(=\""
 487                                               "\\([^\"]+\\)\"\\)?")
 488                                       attrstr))
 489               (let ((attr (cons (downcase
 490                                  (muse-match-string-no-properties 1 attrstr))
 491                                 (muse-match-string-no-properties 3 attrstr))))
 492                 (setq attrstr (replace-match "" t t attrstr))
 493                 (if attrs
 494                     (nconc attrs (list attr))
 495                   (setq attrs (list attr)))))))
 496         (if (and (cadr tag-info) (not closed-tag))
 497             (if (search-forward (concat "</" (car tag-info) ">") nil t)
 498                 (setq end (match-end 0))
 499               (setq tag-info nil)))
 500         (when tag-info
 501           (let ((args (list start end)))
 502             (if (nth 2 tag-info)
 503                 (nconc args (list attrs)))
 504             (apply (nth 3 tag-info) args)))))))
 505
 506 (defun muse-unhighlight-region (begin end &optional verbose)
 507   "Remove all visual highlights in the buffer (except font-lock)."
 508   (let ((buffer-undo-list t)
 509         (inhibit-read-only t)
 510         (inhibit-point-motion-hooks t)
 511         (inhibit-modification-hooks t)
 512         (modified-p (buffer-modified-p))
 513         deactivate-mark)
 514     (unwind-protect
 515         (remove-text-properties
 516          begin end '(face nil font-lock-multiline nil
 517                           invisible nil intangible nil display nil
 518                           mouse-face nil keymap nil help-echo nil))
 519       (set-buffer-modified-p modified-p))))
 520
 521 (defun muse-colors-example-tag (beg end)
 522   "Strip properties and colorize with `muse-verbatim-face'."
 523   (muse-unhighlight-region beg end)
 524   (let ((multi (save-excursion
 525                  (goto-char beg)
 526                  (forward-line 1)
 527                  (> end (point)))))
 528     (add-text-properties beg end `(face muse-verbatim-face
 529                                    font-lock-multiline ,multi))))
 530
 531 (defun muse-colors-literal-tag (beg end)
 532   "Strip properties and mark as literal."
 533   (muse-unhighlight-region beg end)
 534   (let ((multi (save-excursion
 535                  (goto-char beg)
 536                  (forward-line 1)
 537                  (> end (point)))))
 538     (add-text-properties beg end `(font-lock-multiline ,multi))))
 539
 540 (defvar muse-mode-local-map
 541   (let ((map (make-sparse-keymap)))
 542     (define-key map [return] 'muse-follow-name-at-point)
 543     (define-key map [(control ?m)] 'muse-follow-name-at-point)
 544     (define-key map [(shift return)] 'muse-follow-name-at-point-other-window)
 545     (if (featurep 'xemacs)
 546         (progn
 547           (define-key map [(button2)] 'muse-follow-name-at-mouse)
 548           (define-key map [(shift button2)]
 549             'muse-follow-name-at-mouse-other-window))
 550       (define-key map [(shift control ?m)]
 551         'muse-follow-name-at-point-other-window)
 552       (define-key map [mouse-2] 'muse-follow-name-at-mouse)
 553       (define-key map [(shift mouse-2)]
 554         'muse-follow-name-at-mouse-other-window)
 555       (unless (eq emacs-major-version 21)
 556         (set-keymap-parent map muse-mode-map)))
 557     map)
 558   "Local keymap used by Muse while on a link.")
 559
 560 (defvar muse-keymap-property
 561   (if (or (featurep 'xemacs)
 562           (>= emacs-major-version 21))
 563       'keymap
 564     'local-map))
 565
 566 (defsubst muse-link-properties (help-str &optional face)
 567   (append (if face
 568               (list 'face face 'rear-nonsticky t
 569                     muse-keymap-property muse-mode-local-map)
 570             (list 'invisible 'muse 'intangible t 'rear-nonsticky t
 571                   muse-keymap-property muse-mode-local-map))
 572           (list 'mouse-face 'highlight
 573                 'help-echo help-str
 574                 muse-keymap-property muse-mode-local-map)))
 575
 576 (defun muse-link-face (link-name &optional explicit)
 577   "Return the type of LINK-NAME as a face symbol.
 578 For EXPLICIT links, this is either a normal link or a bad-link
 579 face.  For implicit links, it is either colored normally or
 580 ignored."
 581   (save-match-data
 582     (let ((link (if explicit
 583                     (muse-handle-explicit-link link-name)
 584                   (muse-handle-implicit-link link-name))))
 585       (when link
 586         (if (or (not explicit)
 587                 (string-match muse-file-regexp link)
 588                 (string-match muse-url-regexp link))
 589             'muse-link-face
 590           (if (not (featurep 'muse-project))
 591               'muse-link-face
 592             (if (string-match "#" link)
 593                 (setq link (substring link 0 (match-beginning 0))))
 594             (if (or (and (muse-project-of-file)
 595                          (muse-project-page-file link muse-current-project t))
 596                     (file-exists-p link))
 597                 'muse-link-face
 598               (when explicit
 599                 'muse-bad-link-face))))))))
 600
 601 (defun muse-colors-explicit-link ()
 602   "Color explicit links."
 603   (when (eq ?\[ (char-after (match-beginning 0)))
 604     ;; remove flyspell overlays
 605     (when (fboundp 'flyspell-unhighlight-at)
 606       (let ((cur (match-beginning 0)))
 607         (while (> (match-end 0) cur)
 608           (flyspell-unhighlight-at cur)
 609           (setq cur (1+ cur)))))
 610     (save-excursion
 611       (goto-char (match-beginning 0))
 612       (looking-at muse-explicit-link-regexp))
 613     (let* ((link (muse-match-string-no-properties 1))
 614            (desc (muse-match-string-no-properties 2))
 615            (props (muse-link-properties
 616                    desc (muse-link-face link t)))
 617            (invis-props (append props (muse-link-properties desc))))
 618       (if desc
 619           (progn
 620             ;; we put the normal face properties on the invisible
 621             ;; portion too, since emacs sometimes will position
 622             ;; the cursor on an intangible character
 623             (add-text-properties (match-beginning 0)
 624                                  (match-beginning 2) invis-props)
 625             (add-text-properties (match-beginning 2) (match-end 2) props)
 626             (add-text-properties (match-end 2) (match-end 0) invis-props))
 627         (add-text-properties (match-beginning 0)
 628                              (match-beginning 1) invis-props)
 629         (add-text-properties (match-beginning 1) (match-end 0) props)
 630         (add-text-properties (match-end 1) (match-end 0) invis-props))
 631       (goto-char (match-end 0))
 632       (add-text-properties
 633        (match-beginning 0) (match-end 0)
 634        (muse-link-properties (muse-match-string-no-properties 0)
 635                              (muse-link-face link t)))
 636       (goto-char (match-end 0)))))
 637
 638 (defun muse-colors-implicit-link ()
 639   "Color implicit links."
 640   ;; remove flyspell overlays
 641   (when (fboundp 'flyspell-unhighlight-at)
 642     (let ((cur (match-beginning 0)))
 643       (while (> (match-end 0) cur)
 644         (flyspell-unhighlight-at cur)
 645         (setq cur (1+ cur)))))
 646   (unless (or (eq (get-text-property (match-beginning 0) 'invisible) 'muse)
 647               (eq (char-before (match-beginning 0)) ?\")
 648               (eq (char-after (match-end 0)) ?\"))
 649     (let ((link (muse-match-string-no-properties 1))
 650           (face (muse-link-face (match-string 1))))
 651       (when face
 652         (add-text-properties (match-beginning 1) (match-end 0)
 653                              (muse-link-properties
 654                               (muse-match-string-no-properties 1) face))))))
 655
 656 (defun muse-colors-title ()
 657   (add-text-properties (+ 7 (match-beginning 0))
 658                        (muse-line-end-position)
 659                        '(face muse-header-1)))
 660
 661 (provide 'muse-colors)
 662
 663 ;;; muse-colors.el ends here