lisp/muse-colors.el

   1 ;;; muse-colors.el --- coloring and highlighting used by Muse
   2
   3 ;; Copyright (C) 2004, 2005, 2006, 2007 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 3, 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 ;; Per B. Sederberg (per AT med DOT upenn DOT edu) contributed the
  40 ;; viewing of inline images.
  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 (defcustom muse-colors-evaluate-lisp-tags t
  74   "Specify whether to evaluate the contents of <lisp> tags at
  75 display time.  If nil, don't evaluate them.  If non-nil, evaluate
  76 them.
  77
  78 The actual contents of the buffer are not changed, only the
  79 displayed text."
  80   :type 'boolean
  81   :group 'muse-colors)
  82
  83 (defcustom muse-colors-inline-images t
  84   "Specify whether to inline images inside the Emacs buffer.  If
  85 nil, don't inline them.  If non-nil, an image link will be
  86 replaced by the image.
  87
  88 The actual contents of the buffer are not changed, only whether
  89 an image is displayed."
  90   :type 'boolean
  91   :group 'muse-colors)
  92
  93 (defcustom muse-colors-inline-image-method 'default-directory
  94   "Determine how to locate inline images.
  95 Setting this to 'default-directory uses the current directory of
  96 the current Muse buffer.
  97
  98 Setting this to a function calls that function with the filename
  99 of the image to be inlined.  The value that is returned will be
 100 used as the filename of the image."
 101   :type '(choice (const :tag "Current directory" default-directory)
 102                  (const :tag "Publishing directory"
 103                         muse-colors-use-publishing-directory)
 104                  (function :tag "Custom function"))
 105   :group 'muse-colors)
 106
 107 (defvar muse-colors-region-end nil
 108   "Indicate the end of the region that is currently being font-locked.")
 109
 110 ;;;###autoload
 111 (defun muse-colors-toggle-inline-images ()
 112   "Toggle display of inlined images on/off."
 113   (interactive)
 114   ;; toggle the custom setting
 115   (if (not muse-colors-inline-images)
 116       (setq muse-colors-inline-images t)
 117     (setq muse-colors-inline-images nil))
 118   ;; reprocess the buffer
 119   (muse-colors-buffer))
 120
 121 (defvar muse-colors-outline-faces-list
 122   (if (facep 'outline-1)
 123       '(outline-1 outline-2 outline-3 outline-4 outline-5)
 124     ;; these are equivalent in coloring to the outline faces
 125     '(font-lock-function-name-face
 126       font-lock-variable-name-face
 127       font-lock-keyword-face
 128       font-lock-builtin-face
 129       font-lock-comment-face))
 130   "Outline faces to use when assigning Muse header faces.")
 131
 132 (defun muse-make-faces-default (&optional later)
 133   "Generate the default face definitions for headers."
 134   (dolist (num '(1 2 3 4 5))
 135     (let ((newsym (intern (concat "muse-header-" (int-to-string num)))))
 136       ;; put in the proper group and give documentation
 137       (if later
 138           (unless (featurep 'xemacs)
 139             (muse-copy-face 'variable-pitch newsym)
 140             (set-face-attribute newsym nil :height (1+ (* 0.1 (- 5 num)))
 141                                 :weight 'bold))
 142         (if (featurep 'xemacs)
 143             (eval `(defface ,newsym
 144                      '((t (:size
 145                            ,(nth (1- num) '("24pt" "18pt" "14pt" "12pt" "11pt"))
 146                            :bold t)))
 147                      "Muse header face"
 148                      :group 'muse-colors))
 149           (eval `(defface ,newsym
 150                    '((t (:height ,(1+ (* 0.1 (- 5 num)))
 151                                  :inherit variable-pitch
 152                                  :weight bold)))
 153                    "Muse header face"
 154                    :group 'muse-colors)))))))
 155
 156 (progn (muse-make-faces-default))
 157
 158 (defun muse-make-faces (&optional frame)
 159   "Generate face definitions for headers based the user's preferences."
 160   (cond
 161    ((not muse-colors-autogen-headings)
 162     nil)
 163    ((eq muse-colors-autogen-headings t)
 164     (muse-make-faces-default t))
 165    (t
 166     (dolist (num '(1 2 3 4 5))
 167       (let ((newsym (intern (concat "muse-header-" (int-to-string num)))))
 168         ;; copy the desired face definition
 169         (muse-copy-face (nth (1- num) muse-colors-outline-faces-list)
 170                         newsym))))))
 171
 172 ;; after displaying the Emacs splash screen, the faces are wiped out,
 173 ;; so recover from that
 174 (add-hook 'window-setup-hook #'muse-make-faces)
 175 ;; ditto for when a new frame is created
 176 (when (boundp 'after-make-frame-functions)
 177   (add-hook 'after-make-frame-functions #'muse-make-faces))
 178
 179 (defface muse-link
 180   '((((class color) (background light))
 181      (:foreground "blue" :underline "blue" :bold t))
 182     (((class color) (background dark))
 183      (:foreground "cyan" :underline "cyan" :bold t))
 184     (t (:bold t)))
 185   "Face for Muse cross-references."
 186   :group 'muse-colors)
 187
 188 (defface muse-bad-link
 189   '((((class color) (background light))
 190      (:foreground "red" :underline "red" :bold t))
 191     (((class color) (background dark))
 192      (:foreground "coral" :underline "coral" :bold t))
 193     (t (:bold t)))
 194   "Face for bad Muse cross-references."
 195   :group 'muse-colors)
 196
 197 (defface muse-verbatim
 198   '((((class color) (background light))
 199      (:foreground "slate gray"))
 200     (((class color) (background dark))
 201      (:foreground "gray")))
 202   "Face for verbatim text."
 203   :group 'muse-colors)
 204
 205 (defface muse-emphasis-1
 206   '((t (:italic t)))
 207   "Face for italic emphasized text."
 208   :group 'muse-colors)
 209
 210 (defface muse-emphasis-2
 211   '((t (:bold t)))
 212   "Face for bold emphasized text."
 213   :group 'muse-colors)
 214
 215 (defface muse-emphasis-3
 216   '((t (:bold t :italic t)))
 217   "Face for bold italic emphasized text."
 218   :group 'muse-colors)
 219
 220 (muse-copy-face 'italic 'muse-emphasis-1)
 221 (muse-copy-face 'bold 'muse-emphasis-2)
 222 (muse-copy-face 'bold-italic 'muse-emphasis-3)
 223
 224 (defcustom muse-colors-buffer-hook nil
 225   "A hook run after a region is highlighted.
 226 Each function receives three arguments: BEG END VERBOSE.
 227 BEG and END mark the range being highlighted, and VERBOSE specifies
 228 whether progress messages should be displayed to the user."
 229   :type 'hook
 230   :group 'muse-colors)
 231
 232 (defvar muse-colors-regexp nil
 233   "Regexp matching each car of `muse-colors-markup'.")
 234 (defvar muse-colors-vector nil
 235   "Vector of all characters that are part of Muse markup.
 236 This is composed of the 2nd element of each `muse-colors-markup'
 237 entry.")
 238
 239 (defun muse-configure-highlighting (sym val)
 240   "Extract color markup information from VAL and set to SYM.
 241 This is usually called with `muse-colors-markup' as both arguments."
 242   (let ((regexps nil)
 243         (rules nil))
 244     (dolist (rule val)
 245       (let ((value (cond ((symbolp (car rule))
 246                           (symbol-value (car rule)))
 247                          ((stringp (car rule))
 248                           (car rule))
 249                          (t nil))))
 250         (when value
 251           (setq rules (cons rule rules))
 252           (setq regexps (cons value regexps)))))
 253     (setq rules (nreverse rules)
 254           regexps (nreverse regexps))
 255     (setq muse-colors-regexp (concat "\\("
 256                                      (mapconcat #'identity regexps "\\|")
 257                                      "\\)")
 258           muse-colors-vector (make-vector 128 nil))
 259     (while rules
 260       (if (eq (cadr (car rules)) t)
 261           (let ((i 0) (l 128))
 262             (while (< i l)
 263               (unless (aref muse-colors-vector i)
 264                 (aset muse-colors-vector i (nth 2 (car rules))))
 265               (setq i (1+ i))))
 266         (aset muse-colors-vector (cadr (car rules))
 267               (nth 2 (car rules))))
 268       (setq rules (cdr rules))))
 269   (set sym val))
 270
 271 (defun muse-colors-emphasized ()
 272   "Color emphasized text and headings."
 273   ;; Here we need to check four different points - the start and end
 274   ;; of the leading *s, and the start and end of the trailing *s.  We
 275   ;; allow the outsides to be surrounded by whitespace or punctuation,
 276   ;; but no word characters, and the insides must not be surrounded by
 277   ;; whitespace or punctuation.  Thus the following are valid:
 278   ;;
 279   ;; " *foo bar* "
 280   ;; "**foo**,"
 281   ;; and the following is invalid:
 282   ;; "** testing **"
 283   (let* ((beg (match-beginning 0))
 284          (e1 (match-end 0))
 285          (leader (- e1 beg))
 286          b2 e2 multiline)
 287     (unless (or (eq (get-text-property beg 'invisible) 'muse)
 288                 (get-text-property beg 'muse-directive-or-comment))
 289       ;; check if it's a header
 290       (if (eq (char-after e1) ?\ )
 291           (when (or (= beg (point-min))
 292                     (eq (char-before beg) ?\n))
 293             (add-text-properties
 294              (muse-line-beginning-position) (muse-line-end-position)
 295              (list 'face (intern (concat "muse-header-"
 296                                          (int-to-string leader))))))
 297         ;; beginning of line or space or symbol
 298         (when (or (= beg (point-min))
 299                   (eq (char-syntax (char-before beg)) ?\ )
 300                   (memq (char-before beg)
 301                         '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
 302           (save-excursion
 303             (skip-chars-forward "^*<>\n" muse-colors-region-end)
 304             (when (eq (char-after) ?\n)
 305               (setq multiline t)
 306               (skip-chars-forward "^*<>" muse-colors-region-end))
 307             (setq b2 (point))
 308             (skip-chars-forward "*" muse-colors-region-end)
 309             (setq e2 (point))
 310             ;; Abort if space exists just before end
 311             ;; or bad leader
 312             ;; or no '*' at end
 313             ;; or word constituent follows
 314             (unless (or (> leader 5)
 315                         (not (eq leader (- e2 b2)))
 316                         (eq (char-syntax (char-before b2)) ?\ )
 317                         (not (eq (char-after b2) ?*))
 318                         (and (not (eobp))
 319                              (eq (char-syntax (char-after (1+ b2))) ?w)))
 320               (add-text-properties beg e1 '(invisible muse))
 321               (add-text-properties
 322                e1 b2 (list 'face (cond ((= leader 1) 'muse-emphasis-1)
 323                                        ((= leader 2) 'muse-emphasis-2)
 324                                        ((= leader 3) 'muse-emphasis-3))))
 325               (add-text-properties b2 e2 '(invisible muse))
 326               (when multiline
 327                 (add-text-properties
 328                  beg e2 '(font-lock-multiline t))))))))))
 329
 330 (defun muse-colors-underlined ()
 331   "Color underlined text."
 332   (let ((start (match-beginning 0))
 333         multiline)
 334     (unless (or (eq (get-text-property start 'invisible) 'muse)
 335                 (get-text-property start 'muse-directive-or-comment))
 336       ;; beginning of line or space or symbol
 337       (when (or (= start (point-min))
 338                 (eq (char-syntax (char-before start)) ?\ )
 339                 (memq (char-before start)
 340                       '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
 341         (save-excursion
 342           (skip-chars-forward "^_<>\n" muse-colors-region-end)
 343           (when (eq (char-after) ?\n)
 344             (setq multiline t)
 345             (skip-chars-forward "^_<>" muse-colors-region-end))
 346           ;; Abort if space exists just before end
 347           ;; or no '_' at end
 348           ;; or word constituent follows
 349           (unless (or (eq (char-syntax (char-before (point))) ?\ )
 350                       (not (eq (char-after (point)) ?_))
 351                       (and (not (eobp))
 352                            (eq (char-syntax (char-after (1+ (point)))) ?w)))
 353             (add-text-properties start (1+ start) '(invisible muse))
 354             (add-text-properties (1+ start) (point) '(face underline))
 355             (add-text-properties (point)
 356                                  (min (1+ (point)) (point-max))
 357                                  '(invisible muse))
 358             (when multiline
 359               (add-text-properties
 360                start (min (1+ (point)) (point-max))
 361                '(font-lock-multiline t)))))))))
 362
 363 (defun muse-colors-verbatim ()
 364   "Render in teletype and suppress further parsing."
 365   (let ((start (match-beginning 0))
 366         multiline)
 367     (unless (or (eq (get-text-property start 'invisible) 'muse)
 368                 (get-text-property start 'muse-directive-or-comment))
 369       ;; beginning of line or space or symbol
 370       (when (or (= start (point-min))
 371                 (eq (char-syntax (char-before start)) ?\ )
 372                 (memq (char-before start)
 373                       '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
 374         (let ((pos (point)))
 375           (skip-chars-forward "^=\n" muse-colors-region-end)
 376           (when (eq (char-after) ?\n)
 377             (setq multiline t)
 378             (skip-chars-forward "^=" muse-colors-region-end))
 379           ;; Abort if space exists just before end
 380           ;; or no '=' at end
 381           ;; or word constituent follows
 382           (unless (or (eq (char-syntax (char-before (point))) ?\ )
 383                       (not (eq (char-after (point)) ?=))
 384                       (and (not (eobp))
 385                            (eq (char-syntax (char-after (1+ (point)))) ?w)))
 386             (setq pos (min (1+ (point)) (point-max)))
 387             (add-text-properties start (1+ start) '(invisible muse))
 388             (add-text-properties (1+ start) (point) '(face muse-verbatim))
 389             (add-text-properties (point)
 390                                  (min (1+ (point)) (point-max))
 391                                  '(invisible muse))
 392             (when multiline
 393               (add-text-properties
 394                start (min (1+ (point)) (point-max))
 395                '(font-lock-multiline t))))
 396           (goto-char pos))))))
 397
 398 (defcustom muse-colors-markup
 399   `(;; make emphasized text appear emphasized
 400     ("\\*\\{1,5\\}" ?* muse-colors-emphasized)
 401
 402     ;; make underlined text appear underlined
 403     (,(concat "_[^" muse-regexp-blank "_\n]")
 404      ?_ muse-colors-underlined)
 405
 406     ("^#title " ?\# muse-colors-title)
 407
 408     (muse-explicit-link-regexp ?\[ muse-colors-explicit-link)
 409
 410     ;; render in teletype and suppress further parsing
 411     (,(concat "=[^" muse-regexp-blank "=\n]") ?= muse-colors-verbatim)
 412
 413     ;; highlight any markup tags encountered
 414     (muse-tag-regexp ?\< muse-colors-custom-tags)
 415
 416     ;; display comments
 417     (,(concat "^;[" muse-regexp-blank "]") ?\; muse-colors-comment)
 418
 419     ;; this has to come later since it doesn't have a special
 420     ;; character in the second cell
 421     (muse-url-regexp t muse-colors-implicit-link)
 422     )
 423   "Expressions to highlight an Emacs Muse buffer.
 424 These are arranged in a rather special fashion, so as to be as quick as
 425 possible.
 426
 427 Each element of the list is itself a list, of the form:
 428
 429   (LOCATE-REGEXP TEST-CHAR MATCH-FUNCTION)
 430
 431 LOCATE-REGEXP is a partial regexp, and should be the smallest possible
 432 regexp to differentiate this rule from other rules.  It may also be a
 433 symbol containing such a regexp.  The buffer region is scanned only
 434 once, and LOCATE-REGEXP indicates where the scanner should stop to
 435 look for highlighting possibilities.
 436
 437 TEST-CHAR is a char or t.  The character should match the beginning
 438 text matched by LOCATE-REGEXP.  These chars are used to build a vector
 439 for fast MATCH-FUNCTION calling.
 440
 441 MATCH-FUNCTION is the function called when a region has been
 442 identified.  It is responsible for adding the appropriate text
 443 properties to change the appearance of the buffer.
 444
 445 This markup is used to modify the appearance of the original text to
 446 make it look more like the published HTML would look (like making some
 447 markup text invisible, inlining images, etc).
 448
 449 font-lock is used to apply the markup rules, so that they can happen
 450 on a deferred basis.  They are not always accurate, but you can use
 451 \\[font-lock-fontifty-block] near the point of error to force
 452 fontification in that area."
 453   :type '(repeat
 454           (list :tag "Highlight rule"
 455                 (choice (regexp :tag "Locate regexp")
 456                         (symbol :tag "Regexp symbol"))
 457                 (choice (character :tag "Confirm character")
 458                         (const :tag "Default rule" t))
 459                 function))
 460   :set 'muse-configure-highlighting
 461   :group 'muse-colors)
 462
 463 ;; XEmacs users don't have `font-lock-multiline'.
 464 (unless (boundp 'font-lock-multiline)
 465   (defvar font-lock-multiline nil))
 466
 467 (defun muse-use-font-lock ()
 468   "Set up font-locking for Muse."
 469   (muse-add-to-invisibility-spec 'muse)
 470   (set (make-local-variable 'font-lock-multiline) 'undecided)
 471   (set (make-local-variable 'font-lock-defaults)
 472        `(nil t nil nil beginning-of-line
 473          (font-lock-fontify-region-function . muse-colors-region)
 474          (font-lock-unfontify-region-function
 475           . muse-unhighlight-region)))
 476   (set (make-local-variable 'font-lock-fontify-region-function)
 477        'muse-colors-region)
 478   (set (make-local-variable 'font-lock-unfontify-region-function)
 479        'muse-unhighlight-region)
 480   (muse-make-faces)
 481   (muse-configure-highlighting 'muse-colors-markup muse-colors-markup)
 482   (font-lock-mode t))
 483
 484 (defun muse-colors-buffer ()
 485   "Re-highlight the entire Muse buffer."
 486   (interactive)
 487   (muse-colors-region (point-min) (point-max) t))
 488
 489 (defvar muse-colors-fontifying-p nil
 490   "Indicate whether Muse is fontifying the current buffer.")
 491 (make-variable-buffer-local 'muse-colors-fontifying-p)
 492
 493 (defun muse-colors-region (beg end &optional verbose)
 494   "Apply highlighting according to `muse-colors-markup'.
 495 Note that this function should NOT change the buffer, nor should any
 496 of the functions listed in `muse-colors-markup'."
 497   (let ((buffer-undo-list t)
 498         (inhibit-read-only t)
 499         (inhibit-point-motion-hooks t)
 500         (inhibit-modification-hooks t)
 501         (modified-p (buffer-modified-p))
 502         (muse-colors-fontifying-p t)
 503         (muse-colors-region-end end)
 504         deactivate-mark)
 505     (unwind-protect
 506         (save-excursion
 507           (save-restriction
 508             (widen)
 509             ;; check to see if we should expand the beg/end area for
 510             ;; proper multiline matches
 511             (when (and font-lock-multiline
 512                        (> beg (point-min))
 513                        (get-text-property (1- beg) 'font-lock-multiline))
 514               ;; We are just after or in a multiline match.
 515               (setq beg (or (previous-single-property-change
 516                              beg 'font-lock-multiline)
 517                             (point-min)))
 518               (goto-char beg)
 519               (setq beg (muse-line-beginning-position)))
 520             (when font-lock-multiline
 521               (setq end (or (text-property-any end (point-max)
 522                                                'font-lock-multiline nil)
 523                             (point-max))))
 524             (goto-char end)
 525             (setq end (muse-line-beginning-position 2))
 526             ;; Undo any fontification in the area.
 527             (font-lock-unfontify-region beg end)
 528             ;; And apply fontification based on `muse-colors-markup'
 529             (let ((len (float (- end beg)))
 530                   (case-fold-search nil)
 531                   markup-func)
 532               (goto-char beg)
 533               (while (and (< (point) end)
 534                           (re-search-forward muse-colors-regexp end t))
 535                 (if verbose
 536                     (message "Highlighting buffer...%d%%"
 537                              (* (/ (float (- (point) beg)) len) 100)))
 538                 (setq markup-func
 539                       (aref muse-colors-vector
 540                             (char-after (match-beginning 0))))
 541                 (when markup-func (funcall markup-func)))
 542               (run-hook-with-args 'muse-colors-buffer-hook
 543                                   beg end verbose)
 544               (if verbose (message "Highlighting buffer...done")))))
 545       (set-buffer-modified-p modified-p))))
 546
 547 (defcustom muse-colors-tags
 548   '(("example"  t nil nil muse-colors-example-tag)
 549     ("code"     t nil nil muse-colors-example-tag)
 550     ("verbatim" t nil nil muse-colors-literal-tag)
 551     ("lisp"     t t   nil muse-colors-lisp-tag)
 552     ("literal"  t nil nil muse-colors-literal-tag))
 553   "A list of tag specifications for specially highlighting text.
 554 XML-style tags are the best way to add custom highlighting to Muse.
 555 This is easily accomplished by customizing this list of markup tags.
 556
 557 For each entry, the name of the tag is given, whether it expects
 558 a closing tag and/or an optional set of attributes, whether it is
 559 nestable, and a function that performs whatever action is desired
 560 within the delimited region.
 561
 562 The function is called with three arguments, the beginning and
 563 end of the region surrounded by the tags. If properties are
 564 allowed, they are passed as a third argument in the form of an
 565 alist. The `end' argument to the function is the last character
 566 of the enclosed tag or region.
 567
 568 Functions should not modify the contents of the buffer."
 569   :type '(repeat (list (string :tag "Markup tag")
 570                        (boolean :tag "Expect closing tag" :value t)
 571                        (boolean :tag "Parse attributes" :value nil)
 572                        (boolean :tag "Nestable" :value nil)
 573                        function))
 574   :group 'muse-colors)
 575
 576 (defsubst muse-colors-tag-info (tagname &rest args)
 577   "Get tag info associated with TAGNAME, ignoring ARGS."
 578   (assoc tagname muse-colors-tags))
 579
 580 (defun muse-colors-custom-tags ()
 581   "Highlight `muse-colors-tags'."
 582   (save-excursion
 583     (goto-char (match-beginning 0))
 584     (looking-at muse-tag-regexp))
 585   (let ((tag-info (muse-colors-tag-info (match-string 1))))
 586     (when (and tag-info
 587                (not (get-text-property (match-beginning 0)
 588                                        'muse-directive-or-comment)))
 589       (let ((closed-tag (match-string 3))
 590             (start (match-beginning 0))
 591             end attrs)
 592         (when (nth 2 tag-info)
 593           (let ((attrstr (match-string 2)))
 594             (while (and attrstr
 595                         (string-match (concat "\\([^"
 596                                               muse-regexp-blank
 597                                               "=\n]+\\)\\(=\""
 598                                               "\\([^\"]+\\)\"\\)?")
 599                                       attrstr))
 600               (let ((attr (cons (downcase
 601                                  (muse-match-string-no-properties 1 attrstr))
 602                                 (muse-match-string-no-properties 3 attrstr))))
 603                 (setq attrstr (replace-match "" t t attrstr))
 604                 (if attrs
 605                     (nconc attrs (list attr))
 606                   (setq attrs (list attr)))))))
 607         (if (and (cadr tag-info) (not closed-tag))
 608             (if (muse-goto-tag-end (car tag-info) (nth 3 tag-info))
 609                 (setq end (match-end 0))
 610               (setq tag-info nil)))
 611         (when tag-info
 612           (let ((args (list start end)))
 613             (if (nth 2 tag-info)
 614                 (nconc args (list attrs)))
 615             (apply (nth 4 tag-info) args)))))))
 616
 617 (defun muse-unhighlight-region (begin end &optional verbose)
 618   "Remove all visual highlights in the buffer (except font-lock)."
 619   (let ((buffer-undo-list t)
 620         (inhibit-read-only t)
 621         (inhibit-point-motion-hooks t)
 622         (inhibit-modification-hooks t)
 623         (modified-p (buffer-modified-p))
 624         deactivate-mark)
 625     (unwind-protect
 626         (remove-text-properties
 627          begin end '(face nil font-lock-multiline nil end-glyph nil
 628                           invisible nil intangible nil display nil
 629                           mouse-face nil keymap nil help-echo nil
 630                           muse-link nil))
 631       (set-buffer-modified-p modified-p))))
 632
 633 (defun muse-colors-example-tag (beg end)
 634   "Strip properties and colorize with `muse-verbatim'."
 635   (muse-unhighlight-region beg end)
 636   (let ((multi (save-excursion
 637                  (goto-char beg)
 638                  (forward-line 1)
 639                  (> end (point)))))
 640     (add-text-properties beg end `(face muse-verbatim
 641                                    font-lock-multiline ,multi))))
 642
 643 (defun muse-colors-literal-tag (beg end)
 644   "Strip properties and mark as literal."
 645   (muse-unhighlight-region beg end)
 646   (let ((multi (save-excursion
 647                  (goto-char beg)
 648                  (forward-line 1)
 649                  (> end (point)))))
 650     (add-text-properties beg end `(font-lock-multiline ,multi))))
 651
 652 (defun muse-colors-lisp-tag (beg end attrs)
 653   "Color the region enclosed by a <lisp> tag."
 654   (if (not muse-colors-evaluate-lisp-tags)
 655       (muse-colors-literal-tag beg end)
 656     (muse-unhighlight-region beg end)
 657     (let (beg-lisp end-lisp)
 658       (save-match-data
 659         (goto-char beg)
 660         (setq beg-lisp (and (looking-at "<[^>]+>")
 661                             (match-end 0)))
 662         (goto-char end)
 663         (setq end-lisp (and (muse-looking-back "</[^>]+>")
 664                             (match-beginning 0))))
 665       (add-text-properties
 666        beg end
 667        (list 'font-lock-multiline t
 668              'display (muse-eval-lisp
 669                        (concat
 670                         "(progn "
 671                         (buffer-substring-no-properties beg-lisp end-lisp)
 672                         ")"))
 673              'intangible t)))))
 674
 675 (defvar muse-mode-local-map
 676   (let ((map (make-sparse-keymap)))
 677     (define-key map [return] 'muse-follow-name-at-point)
 678     (define-key map [(control ?m)] 'muse-follow-name-at-point)
 679     (define-key map [(shift return)] 'muse-follow-name-at-point-other-window)
 680     (if (featurep 'xemacs)
 681         (progn
 682           (define-key map [(button2)] 'muse-follow-name-at-mouse)
 683           (define-key map [(shift button2)]
 684             'muse-follow-name-at-mouse-other-window))
 685       (define-key map [(shift control ?m)]
 686         'muse-follow-name-at-point-other-window)
 687       (define-key map [mouse-2] 'muse-follow-name-at-mouse)
 688       (define-key map [(shift mouse-2)]
 689         'muse-follow-name-at-mouse-other-window)
 690       (unless (eq emacs-major-version 21)
 691         (set-keymap-parent map muse-mode-map)))
 692     map)
 693   "Local keymap used by Muse while on a link.")
 694
 695 (defvar muse-keymap-property
 696   (if (or (featurep 'xemacs)
 697           (>= emacs-major-version 21))
 698       'keymap
 699     'local-map)
 700   "The name of the keymap or local-map property.")
 701
 702 (defsubst muse-link-properties (help-str &optional face)
 703   "Determine text properties to use for a link."
 704   (append (if face
 705               (list 'face face 'mouse-face 'highlight 'muse-link t)
 706             (list 'invisible 'muse 'intangible t))
 707           (list 'help-echo help-str 'rear-nonsticky t
 708                 muse-keymap-property muse-mode-local-map)))
 709
 710 (defun muse-link-face (link-name &optional explicit)
 711   "Return the type of LINK-NAME as a face symbol.
 712 For EXPLICIT links, this is either a normal link or a bad-link
 713 face.  For implicit links, it is either colored normally or
 714 ignored."
 715   (save-match-data
 716     (let ((link (if explicit
 717                     (muse-handle-explicit-link link-name)
 718                   (muse-handle-implicit-link link-name))))
 719       (when link
 720         (cond ((string-match muse-url-regexp link)
 721                'muse-link)
 722               ((muse-file-remote-p link)
 723                'muse-link)
 724               ((string-match muse-file-regexp link)
 725                (when (string-match "/[^/]+#[^#./]+\\'" link)
 726                  ;; strip anchor from the end of a path
 727                  (setq link (substring link 0 (match-beginning 0))))
 728                (if (file-exists-p link)
 729                    'muse-link
 730                  'muse-bad-link))
 731               ((not (featurep 'muse-project))
 732                'muse-link)
 733               (t
 734                (if (string-match "#" link)
 735                    (setq link (substring link 0 (match-beginning 0))))
 736                (if (or (and (muse-project-of-file)
 737                             (muse-project-page-file
 738                              link muse-current-project t))
 739                        (file-exists-p link))
 740                    'muse-link
 741                  'muse-bad-link)))))))
 742
 743 (defun muse-colors-use-publishing-directory (link)
 744   "Make LINK relative to the directory where we will publish the
 745 current file."
 746   (let ((style (car (muse-project-applicable-styles
 747                      link (cddr (muse-project)))))
 748         path)
 749     (when (and style
 750                (setq path (muse-style-element :path style)))
 751       (expand-file-name link path))))
 752
 753 (defun muse-colors-resolve-image-file (link)
 754   "Determine if we can create images and see if the link is an image
 755 file."
 756   (save-match-data
 757     (and (or (fboundp 'create-image)
 758              (fboundp 'make-glyph))
 759          (not (string-match "\\`[uU][rR][lL]:" link))
 760          (string-match muse-image-regexp link))))
 761
 762 (defun muse-make-file-glyph (filename)
 763   "Given a file name, return a newly-created image glyph.
 764 This is a hack for supporting inline images in XEmacs."
 765   (let ((case-fold-search nil))
 766     ;; Scan filename to determine image type
 767     (when (fboundp 'make-glyph)
 768       (save-match-data
 769         (cond ((string-match "jpe?g" filename)
 770                (make-glyph (vector 'jpeg :file filename) 'buffer))
 771               ((string-match "gif" filename)
 772                (make-glyph (vector 'gif :file filename) 'buffer))
 773               ((string-match "png" filename)
 774                (make-glyph (vector 'png :file filename) 'buffer)))))))
 775
 776 (defun muse-colors-insert-image (link beg end invis-props)
 777   "Create an image using create-image or make-glyph and insert it
 778 in place of an image link defined by BEG and END."
 779   (setq link (expand-file-name link))
 780   (let ((image-file (cond
 781                      ((eq muse-colors-inline-image-method 'default-directory)
 782                       link)
 783                      ((functionp muse-colors-inline-image-method)
 784                       (funcall muse-colors-inline-image-method link))))
 785         glyph)
 786     (when (stringp image-file)
 787       (if (fboundp 'create-image)
 788           ;; use create-image and display property
 789           (let ((display-stuff (condition-case nil
 790                                    (create-image image-file)
 791                                  (error nil))))
 792             (when display-stuff
 793               (add-text-properties beg end (list 'display display-stuff))))
 794         ;; use make-glyph and invisible property
 795         (and (setq glyph (muse-make-file-glyph image-file))
 796              (progn
 797                (add-text-properties beg end invis-props)
 798                (add-text-properties beg end (list
 799                                              'end-glyph glyph
 800                                              'help-echo link))))))))
 801
 802 (defun muse-colors-explicit-link ()
 803   "Color explicit links."
 804   (when (and (eq ?\[ (char-after (match-beginning 0)))
 805              (not (get-text-property (match-beginning 0)
 806                                      'muse-directive-or-comment)))
 807     ;; remove flyspell overlays
 808     (when (fboundp 'flyspell-unhighlight-at)
 809       (let ((cur (match-beginning 0)))
 810         (while (> (match-end 0) cur)
 811           (flyspell-unhighlight-at cur)
 812           (setq cur (1+ cur)))))
 813     (save-excursion
 814       (goto-char (match-beginning 0))
 815       (looking-at muse-explicit-link-regexp))
 816     (let* ((unesc-link (muse-get-link))
 817            (unesc-desc (muse-get-link-desc))
 818            (link (muse-link-unescape unesc-link))
 819            (desc (muse-link-unescape unesc-desc))
 820            (props (muse-link-properties desc (muse-link-face link t)))
 821            (invis-props (append props (muse-link-properties desc))))
 822       ;; see if we should try and inline an image
 823       (if (and muse-colors-inline-images
 824                (or (muse-colors-resolve-image-file link)
 825                    (and desc
 826                         (muse-colors-resolve-image-file desc)
 827                         (setq link desc))))
 828           ;; we found an image, so inline it
 829           (muse-colors-insert-image
 830            link
 831            (match-beginning 0) (match-end 0) invis-props)
 832         (if desc
 833             (progn
 834               ;; we put the normal face properties on the invisible
 835               ;; portion too, since emacs sometimes will position
 836               ;; the cursor on an intangible character
 837               (add-text-properties (match-beginning 0)
 838                                    (match-beginning 2) invis-props)
 839               (add-text-properties (match-beginning 2) (match-end 2) props)
 840               (add-text-properties (match-end 2) (match-end 0) invis-props)
 841               ;; in case specials were escaped, cause the unescaped
 842               ;; text to be displayed
 843               (unless (string= desc unesc-desc)
 844                 (add-text-properties (match-beginning 2) (match-end 2)
 845                                      (list 'display desc))))
 846           (add-text-properties (match-beginning 0)
 847                                (match-beginning 1) invis-props)
 848           (add-text-properties (match-beginning 1) (match-end 0) props)
 849           (add-text-properties (match-end 1) (match-end 0) invis-props)
 850           (unless (string= link unesc-link)
 851             (add-text-properties (match-beginning 1) (match-end 1)
 852                                  (list 'display link))))
 853         (goto-char (match-end 0))
 854         (add-text-properties
 855          (match-beginning 0) (match-end 0)
 856          (muse-link-properties (muse-match-string-no-properties 0)
 857                                (muse-link-face link t)))))))
 858
 859 (defun muse-colors-implicit-link ()
 860   "Color implicit links."
 861   (unless (or (eq (get-text-property (match-beginning 0) 'invisible) 'muse)
 862               (get-text-property (match-beginning 0)
 863                                  'muse-directive-or-comment)
 864               (eq (char-before (match-beginning 0)) ?\")
 865               (eq (char-after (match-end 0)) ?\"))
 866     ;; remove flyspell overlays
 867     (when (fboundp 'flyspell-unhighlight-at)
 868       (let ((cur (match-beginning 0)))
 869         (while (> (match-end 0) cur)
 870           (flyspell-unhighlight-at cur)
 871           (setq cur (1+ cur)))))
 872     ;; colorize link
 873     (let ((link (muse-match-string-no-properties 1))
 874           (face (muse-link-face (match-string 1))))
 875       (when face
 876         (add-text-properties (match-beginning 1) (match-end 0)
 877                              (muse-link-properties
 878                               (muse-match-string-no-properties 1) face))))))
 879
 880 (defun muse-colors-title ()
 881   "Color #title directives."
 882   (add-text-properties (+ 7 (match-beginning 0)) (muse-line-end-position)
 883                        (list 'face 'muse-header-1
 884                              'muse-directive-or-comment t)))
 885
 886 (defun muse-colors-comment ()
 887   "Color comments."
 888   (add-text-properties (match-beginning 0) (muse-line-end-position)
 889                        (list 'face 'font-lock-comment-face
 890                              'muse-directive-or-comment t)))
 891
 892
 893 (provide 'muse-colors)
 894
 895 ;;; muse-colors.el ends here