lisp/muse-colors.el

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