lisp/muse-colors.el

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