path: root/emacs.d/elisp/muse/muse-colors.el

;;; muse-colors.el --- coloring and highlighting used by Muse

;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010
;;   Free Software Foundation, Inc.

;; Author: John Wiegley (johnw AT gnu DOT org)
;; Keywords: hypermedia
;; Date: Thu 11-Mar-2004

;; This file is part of Emacs Muse.  It is not part of GNU Emacs.

;; Emacs Muse is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published
;; by the Free Software Foundation; either version 3, or (at your
;; option) any later version.

;; Emacs Muse is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with Emacs Muse; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; Contributors:

;; Lan Yufeng (nlany DOT web AT gmail DOT com) found an error where
;; headings were being given the wrong face, contributing a patch to
;; fix this.

;; Sergey Vlasov (vsu AT altlinux DOT ru) fixed an issue with coloring
;; links that are in consecutive lines.

;; Jim Ottaway ported the <lisp> tag from emacs-wiki.

;; Per B. Sederberg (per AT med DOT upenn DOT edu) contributed the
;; viewing of inline images.

;;; Code:

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Emacs Muse Highlighting
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require 'muse-mode)
(require 'muse-regexps)
(require 'font-lock)

(defgroup muse-colors nil
  "Options controlling the behavior of Emacs Muse highlighting.
See `muse-colors-buffer' for more information."
  :group 'muse-mode)

(defcustom muse-colors-autogen-headings t
  "Specify whether the heading faces should be auto-generated.
The default is to scale them.

Choosing 'outline will copy the colors from the outline-mode
headings.

If you want to customize each of the headings individually, set
this to nil."
  :type '(choice (const :tag "Default (scaled) headings" t)
                 (const :tag "Use outline-mode headings" outline)
                 (const :tag "Don't touch the headings" nil))
  :group 'muse-colors)

(defcustom muse-colors-evaluate-lisp-tags t
  "Specify whether to evaluate the contents of <lisp> tags at
display time.  If nil, don't evaluate them.  If non-nil, evaluate
them.

The actual contents of the buffer are not changed, only the
displayed text."
  :type 'boolean
  :group 'muse-colors)

(defcustom muse-colors-inline-images t
  "Specify whether to inline images inside the Emacs buffer.  If
nil, don't inline them.  If non-nil, an image link will be
replaced by the image.

The actual contents of the buffer are not changed, only whether
an image is displayed."
  :type 'boolean
  :group 'muse-colors)

(defcustom muse-colors-inline-image-method 'default-directory
  "Determine how to locate inline images.
Setting this to 'default-directory uses the current directory of
the current Muse buffer.

Setting this to a function calls that function with the filename
of the image to be inlined.  The value that is returned will be
used as the filename of the image."
  :type '(choice (const :tag "Current directory" default-directory)
                 (const :tag "Publishing directory"
                        muse-colors-use-publishing-directory)
                 (function :tag "Custom function"))
  :group 'muse-colors)

(defvar muse-colors-region-end nil
  "Indicate the end of the region that is currently being font-locked.")
(make-variable-buffer-local 'muse-colors-region-end)

;;;###autoload
(defun muse-colors-toggle-inline-images ()
  "Toggle display of inlined images on/off."
  (interactive)
  ;; toggle the custom setting
  (if (not muse-colors-inline-images)
      (setq muse-colors-inline-images t)
    (setq muse-colors-inline-images nil))
  ;; reprocess the buffer
  (muse-colors-buffer)
  ;; display informative message
  (if muse-colors-inline-images
      (message "Images are now displayed inline")
    (message "Images are now displayed as links")))

(defvar muse-colors-outline-faces-list
  (if (facep 'outline-1)
      '(outline-1 outline-2 outline-3 outline-4 outline-5)
    ;; these are equivalent in coloring to the outline faces
    '(font-lock-function-name-face
      font-lock-variable-name-face
      font-lock-keyword-face
      font-lock-builtin-face
      font-lock-comment-face))
  "Outline faces to use when assigning Muse header faces.")

(defun muse-make-faces-default (&optional later)
  "Generate the default face definitions for headers."
  (dolist (num '(1 2 3 4 5))
    (let ((newsym (intern (concat "muse-header-" (int-to-string num))))
          (docstring (concat
                      "Muse header face.  See "
                      "`muse-colors-autogen-headings' before changing it.")))
      ;; put in the proper group and give documentation
      (if later
          (unless (featurep 'xemacs)
            (muse-copy-face 'variable-pitch newsym)
            (set-face-attribute newsym nil :height (1+ (* 0.1 (- 5 num)))
                                :weight 'bold))
        (if (featurep 'xemacs)
            (eval `(defface ,newsym
                     '((t (:size
                           ,(nth (1- num)
                                 '("24pt" "18pt" "14pt" "12pt" "11pt"))
                           :bold t)))
                     ,docstring
                     :group 'muse-colors))
          (eval `(defface ,newsym
                   '((t (:height ,(1+ (* 0.1 (- 5 num)))
                                 :inherit variable-pitch
                                 :weight bold)))
                   ,docstring
                   :group 'muse-colors)))))))

(progn (muse-make-faces-default))

(defun muse-make-faces (&optional frame)
  "Generate face definitions for headers based the user's preferences."
  (cond
   ((not muse-colors-autogen-headings)
    nil)
   ((eq muse-colors-autogen-headings t)
    (muse-make-faces-default t))
   (t
    (dolist (num '(1 2 3 4 5))
      (let ((newsym (intern (concat "muse-header-" (int-to-string num)))))
        ;; copy the desired face definition
        (muse-copy-face (nth (1- num) muse-colors-outline-faces-list)
                        newsym))))))

;; after displaying the Emacs splash screen, the faces are wiped out,
;; so recover from that
(add-hook 'window-setup-hook #'muse-make-faces)
;; ditto for when a new frame is created
(when (boundp 'after-make-frame-functions)
  (add-hook 'after-make-frame-functions #'muse-make-faces))

(defface muse-link
  '((((class color) (background light))
     (:foreground "blue" :underline "blue" :bold t))
    (((class color) (background dark))
     (:foreground "cyan" :underline "cyan" :bold t))
    (t (:bold t)))
  "Face for Muse cross-references."
  :group 'muse-colors)

(defface muse-bad-link
  '((((class color) (background light))
     (:foreground "red" :underline "red" :bold t))
    (((class color) (background dark))
     (:foreground "coral" :underline "coral" :bold t))
    (t (:bold t)))
  "Face for bad Muse cross-references."
  :group 'muse-colors)

(defface muse-verbatim
  '((((class color) (background light))
     (:foreground "slate gray"))
    (((class color) (background dark))
     (:foreground "gray")))
  "Face for verbatim text."
  :group 'muse-colors)

(defface muse-emphasis-1
  '((t (:italic t)))
  "Face for italic emphasized text."
  :group 'muse-colors)

(defface muse-emphasis-2
  '((t (:bold t)))
  "Face for bold emphasized text."
  :group 'muse-colors)

(defface muse-emphasis-3
  '((t (:bold t :italic t)))
  "Face for bold italic emphasized text."
  :group 'muse-colors)

(muse-copy-face 'italic 'muse-emphasis-1)
(muse-copy-face 'bold 'muse-emphasis-2)
(muse-copy-face 'bold-italic 'muse-emphasis-3)

(defcustom muse-colors-buffer-hook nil
  "A hook run after a region is highlighted.
Each function receives three arguments: BEG END VERBOSE.
BEG and END mark the range being highlighted, and VERBOSE specifies
whether progress messages should be displayed to the user."
  :type 'hook
  :group 'muse-colors)

(defvar muse-colors-highlighting-registry nil
  "The rules for highlighting Muse and Muse-derived buffers.
This is automatically generated when using font-lock in Muse buffers.

This an alist of major-mode symbols to `muse-colors-rule' objects.")

(defun muse-colors-make-highlighting-struct ()
  (list nil nil nil))
(defconst muse-colors-highlighting.regexp 0
  "Regexp matching each car of the markup of the current rule.")
(defconst muse-colors-highlighting.vector 1
  "Vector of all characters that are part of the markup of the current rule.
This is composed of the 2nd element of each markup entry.")
(defconst muse-colors-highlighting.remaining 2
  "Expressions for highlighting a buffer which have no corresponding
entry in the vector.")

(defsubst muse-colors-highlighting-entry (mode)
  "Return the highlighting rules for MODE."
  (assq mode muse-colors-highlighting-registry))

(defun muse-colors-find-highlighting (mode)
  "Return the highlighting rules to be used for MODE.
If MODE does not have highlighting rules, check its parent modes."
  (let ((seen nil))
    (catch 'rules
      (while (and mode (not (memq mode seen)))
        (let ((entry (muse-colors-highlighting-entry mode)))
          (when entry (throw 'rules (cdr entry))))
        (setq seen (cons mode seen))
        (setq mode (get mode 'derived-mode-parent)))
      nil)))

(defun muse-colors-define-highlighting (mode markup)
  "Create or update the markup rules for MODE, using MARKUP.

See `muse-colors-markup' for an explanation of the format that MARKUP
should take."
  (unless (and (symbolp mode) mode (consp markup))
    (error "Invalid arguments"))
  (let* ((highlighting-entry (muse-colors-highlighting-entry mode))
         (struct (cdr highlighting-entry))
         (regexp nil)
         (vector nil)
         (remaining nil))
    ;; Initialize struct
    (if struct
        (setq vector (nth muse-colors-highlighting.vector struct))
      (setq struct (muse-colors-make-highlighting-struct)))
    ;; Initialize vector
    (if vector
        (let ((i 0))
          (while (< i 128)
            (aset vector i nil)
            (setq i (1+ i))))
      (setq vector (make-vector 128 nil)))
    ;; Determine vector, regexp, remaining
    (let ((regexps nil)
          (rules nil))
      (dolist (rule markup)
        (let ((value (cond ((symbolp (car rule))
                            (symbol-value (car rule)))
                           ((stringp (car rule))
                            (car rule))
                           (t nil))))
          (when value
            (setq rules (cons rule rules))
            (setq regexps (cons value regexps)))))
      (setq regexps (nreverse regexps))
      (setq regexp (concat "\\(" (mapconcat #'identity regexps "\\|") "\\)"))
      (dolist (rule rules)
        (if (eq (nth 1 rule) t)
            (setq remaining (cons (cons (nth 0 rule) (nth 2 rule))
                                  remaining))
          (aset vector (nth 1 rule)
                (cons (cons (nth 0 rule) (nth 2 rule))
                      (aref vector (nth 1 rule)))))))
    ;; Update the struct
    (setcar (nthcdr muse-colors-highlighting.regexp struct) regexp)
    (setcar (nthcdr muse-colors-highlighting.vector struct) vector)
    (setcar (nthcdr muse-colors-highlighting.remaining struct) remaining)
    ;; Update entry for mode in muse-colors-highlighting-registry
    (if highlighting-entry
        (setcdr highlighting-entry struct)
      (setq muse-colors-highlighting-registry
            (cons (cons mode struct)
                  muse-colors-highlighting-registry)))))

(defun muse-configure-highlighting (sym val)
  "Extract color markup information from VAL and set to SYM.
This is usually called with `muse-colors-markup' as both arguments."
  (muse-colors-define-highlighting 'muse-mode val)
  (set sym val))

(defun muse-colors-emphasized ()
  "Color emphasized text and headings."
  ;; Here we need to check four different points - the start and end
  ;; of the leading *s, and the start and end of the trailing *s.  We
  ;; allow the outsides to be surrounded by whitespace or punctuation,
  ;; but no word characters, and the insides must not be surrounded by
  ;; whitespace or punctuation.  Thus the following are valid:
  ;;
  ;; " *foo bar* "
  ;; "**foo**,"
  ;; and the following is invalid:
  ;; "** testing **"
  (let* ((beg (match-beginning 0))
         (e1 (match-end 0))
         (leader (- e1 beg))
         b2 e2 multiline)
    (unless (or (eq (get-text-property beg 'invisible) 'muse)
                (get-text-property beg 'muse-comment)
                (get-text-property beg 'muse-directive))
      ;; check if it's a header
      (if (eq (char-after e1) ?\ )
          (when (or (= beg (point-min))
                    (eq (char-before beg) ?\n))
            (add-text-properties
             (muse-line-beginning-position) (muse-line-end-position)
             (list 'face (intern (concat "muse-header-"
                                         (int-to-string leader))))))
        ;; beginning of line or space or symbol
        (when (or (= beg (point-min))
                  (eq (char-syntax (char-before beg)) ?\ )
                  (memq (char-before beg)
                        '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
          (save-excursion
            (skip-chars-forward "^*<>\n" muse-colors-region-end)
            (when (eq (char-after) ?\n)
              (setq multiline t)
              (skip-chars-forward "^*<>" muse-colors-region-end))
            (setq b2 (point))
            (skip-chars-forward "*" muse-colors-region-end)
            (setq e2 (point))
            ;; Abort if space exists just before end
            ;; or bad leader
            ;; or no '*' at end
            ;; or word constituent follows
            (unless (or (> leader 5)
                        (not (eq leader (- e2 b2)))
                        (eq (char-syntax (char-before b2)) ?\ )
                        (not (eq (char-after b2) ?*))
                        (and (not (eobp))
                             (eq (char-syntax (char-after (1+ b2))) ?w)))
              (add-text-properties beg e1 '(invisible muse))
              (add-text-properties
               e1 b2 (list 'face (cond ((= leader 1) 'muse-emphasis-1)
                                       ((= leader 2) 'muse-emphasis-2)
                                       ((= leader 3) 'muse-emphasis-3))))
              (add-text-properties b2 e2 '(invisible muse))
              (when multiline
                (add-text-properties
                 beg e2 '(font-lock-multiline t))))))))))

(defun muse-colors-underlined ()
  "Color underlined text."
  (let ((start (match-beginning 0))
        multiline)
    (unless (or (eq (get-text-property start 'invisible) 'muse)
                (get-text-property start 'muse-comment)
                (get-text-property start 'muse-directive))
      ;; beginning of line or space or symbol
      (when (or (= start (point-min))
                (eq (char-syntax (char-before start)) ?\ )
                (memq (char-before start)
                      '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
        (save-excursion
          (skip-chars-forward "^_<>\n" muse-colors-region-end)
          (when (eq (char-after) ?\n)
            (setq multiline t)
            (skip-chars-forward "^_<>" muse-colors-region-end))
          ;; Abort if space exists just before end
          ;; or no '_' at end
          ;; or word constituent follows
          (unless (or (eq (char-syntax (char-before (point))) ?\ )
                      (not (eq (char-after (point)) ?_))
                      (and (not (eobp))
                           (eq (char-syntax (char-after (1+ (point)))) ?w)))
            (add-text-properties start (1+ start) '(invisible muse))
            (add-text-properties (1+ start) (point) '(face underline))
            (add-text-properties (point)
                                 (min (1+ (point)) (point-max))
                                 '(invisible muse))
            (when multiline
              (add-text-properties
               start (min (1+ (point)) (point-max))
               '(font-lock-multiline t)))))))))

(defun muse-colors-verbatim ()
  "Render in teletype and suppress further parsing."
  (let ((start (match-beginning 0))
        multiline)
    (unless (or (eq (get-text-property start 'invisible) 'muse)
                (get-text-property start 'muse-comment)
                (get-text-property start 'muse-directive))
      ;; beginning of line or space or symbol
      (when (or (= start (point-min))
                (eq (char-syntax (char-before start)) ?\ )
                (memq (char-before start)
                      '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
        (let ((pos (point)))
          (skip-chars-forward "^=\n" muse-colors-region-end)
          (when (eq (char-after) ?\n)
            (setq multiline t)
            (skip-chars-forward "^=" muse-colors-region-end))
          ;; Abort if space exists just before end
          ;; or no '=' at end
          ;; or word constituent follows
          (unless (or (eq (char-syntax (char-before (point))) ?\ )
                      (not (eq (char-after (point)) ?=))
                      (and (not (eobp))
                           (eq (char-syntax (char-after (1+ (point)))) ?w)))
            (setq pos (min (1+ (point)) (point-max)))
            (add-text-properties start (1+ start) '(invisible muse))
            (add-text-properties (1+ start) (point) '(face muse-verbatim))
            (add-text-properties (point)
                                 (min (1+ (point)) (point-max))
                                 '(invisible muse))
            (when multiline
              (add-text-properties
               start (min (1+ (point)) (point-max))
               '(font-lock-multiline t))))
          (goto-char pos))))))

(defcustom muse-colors-markup
  `(;; make emphasized text appear emphasized
    ("\\*\\{1,5\\}" ?* muse-colors-emphasized)

    ;; make underlined text appear underlined
    (,(concat "_[^" muse-regexp-blank "_\n]")
     ?_ muse-colors-underlined)

    ("^#title " ?\# muse-colors-title)

    (muse-explicit-link-regexp ?\[ muse-colors-explicit-link)

    ;; render in teletype and suppress further parsing
    (,(concat "=[^" muse-regexp-blank "=\n]") ?= muse-colors-verbatim)

    ;; highlight any markup tags encountered
    (muse-tag-regexp ?\< muse-colors-custom-tags)

    ;; display comments
    (,(concat "^;[" muse-regexp-blank "]") ?\; muse-colors-comment)

    ;; this has to come later since it doesn't have a special
    ;; character in the second cell
    (muse-url-regexp t muse-colors-implicit-link)
    )
  "Expressions to highlight an Emacs Muse buffer.
These are arranged in a rather special fashion, so as to be as quick as
possible.

Each element of the list is itself a list, of the form:

  (LOCATE-REGEXP TEST-CHAR MATCH-FUNCTION)

LOCATE-REGEXP is a partial regexp, and should be the smallest possible
regexp to differentiate this rule from other rules.  It may also be a
symbol containing such a regexp.  The buffer region is scanned only
once, and LOCATE-REGEXP indicates where the scanner should stop to
look for highlighting possibilities.

TEST-CHAR is a char or t.  The character should match the beginning
text matched by LOCATE-REGEXP.  These chars are used to build a vector
for fast MATCH-FUNCTION calling.

MATCH-FUNCTION is the function called when a region has been
identified.  It is responsible for adding the appropriate text
properties to change the appearance of the buffer.

This markup is used to modify the appearance of the original text to
make it look more like the published HTML would look (like making some
markup text invisible, inlining images, etc).

font-lock is used to apply the markup rules, so that they can happen
on a deferred basis.  They are not always accurate, but you can use
\\[font-lock-fontifty-block] near the point of error to force
fontification in that area."
  :type '(repeat
          (list :tag "Highlight rule"
                (choice (regexp :tag "Locate regexp")
                        (symbol :tag "Regexp symbol"))
                (choice (character :tag "Confirm character")
                        (const :tag "Default rule" t))
                function))
  :set 'muse-configure-highlighting
  :group 'muse-colors)

;; XEmacs users don't have `font-lock-multiline'.
(unless (boundp 'font-lock-multiline)
  (defvar font-lock-multiline nil))

(defun muse-use-font-lock ()
  "Set up font-locking for Muse."
  (muse-add-to-invisibility-spec 'muse)
  (set (make-local-variable 'font-lock-multiline) 'undecided)
  (set (make-local-variable 'font-lock-defaults)
       `(nil t nil nil beginning-of-line
         (font-lock-fontify-region-function . muse-colors-region)
         (font-lock-unfontify-region-function
          . muse-unhighlight-region)))
  (set (make-local-variable 'font-lock-fontify-region-function)
       'muse-colors-region)
  (set (make-local-variable 'font-lock-unfontify-region-function)
       'muse-unhighlight-region)
  (muse-make-faces)
  (muse-colors-define-highlighting 'muse-mode muse-colors-markup)
  (font-lock-mode t))

(defun muse-colors-buffer ()
  "Re-highlight the entire Muse buffer."
  (interactive)
  (muse-colors-region (point-min) (point-max) t))

(defvar muse-colors-fontifying-p nil
  "Indicate whether Muse is fontifying the current buffer.")
(make-variable-buffer-local 'muse-colors-fontifying-p)

(defvar muse-colors-delayed-commands nil
  "Commands to be run immediately after highlighting a region.

This is meant to accommodate highlighting <lisp> in #title
directives after everything else.

It may be modified by Muse functions during highlighting, but not
the user.")
(make-variable-buffer-local 'muse-colors-delayed-commands)

(defun muse-colors-region (beg end &optional verbose)
  "Apply highlighting according to `muse-colors-markup'.
Note that this function should NOT change the buffer, nor should any
of the functions listed in `muse-colors-markup'."
  (let ((buffer-undo-list t)
        (inhibit-read-only t)
        (inhibit-point-motion-hooks t)
        (inhibit-modification-hooks t)
        (modified-p (buffer-modified-p))
        (muse-colors-fontifying-p t)
        (muse-colors-region-end (muse-line-end-position end))
        (muse-colors-delayed-commands nil)
        (highlighting (muse-colors-find-highlighting major-mode))
        regexp vector remaining
        deactivate-mark)
    (unless highlighting
      (error "No highlighting found for this mode"))
    (setq regexp (nth muse-colors-highlighting.regexp highlighting)
          vector (nth muse-colors-highlighting.vector highlighting)
          remaining (nth muse-colors-highlighting.remaining highlighting))
    (unwind-protect
        (save-excursion
          (save-restriction
            (widen)
            ;; check to see if we should expand the beg/end area for
            ;; proper multiline matches
            (when (and font-lock-multiline
                       (> beg (point-min))
                       (get-text-property (1- beg) 'font-lock-multiline))
              ;; We are just after or in a multiline match.
              (setq beg (or (previous-single-property-change
                             beg 'font-lock-multiline)
                            (point-min)))
              (goto-char beg)
              (setq beg (muse-line-beginning-position)))
            (when font-lock-multiline
              (setq end (or (text-property-any end (point-max)
                                               'font-lock-multiline nil)
                            (point-max))))
            (goto-char end)
            (setq end (muse-line-beginning-position 2))
            ;; Undo any fontification in the area.
            (font-lock-unfontify-region beg end)
            ;; And apply fontification based on `muse-colors-markup'
            (let ((len (float (- end beg)))
                  (case-fold-search nil)
                  markup-list)
              (goto-char beg)
              (while (and (< (point) end)
                          (re-search-forward regexp end t))
                (if verbose
                    (message "Highlighting buffer...%d%%"
                             (* (/ (float (- (point) beg)) len) 100)))
                (let ((ch (char-after (match-beginning 0))))
                  (when (< ch 128)
                    (setq markup-list (aref vector ch))))
                (unless markup-list
                  (setq markup-list remaining))
                (let ((prev (point)))
                  ;; backtrack and figure out which rule matched
                  (goto-char (match-beginning 0))
                  (catch 'done
                    (dolist (entry markup-list)
                      (let ((value (cond ((symbolp (car entry))
                                          (symbol-value (car entry)))
                                         ((stringp (car entry))
                                          (car entry))
                                         (t nil))))
                        (when (and (stringp value) (looking-at value))
                          (goto-char (match-end 0))
                          (when (cdr entry)
                            (funcall (cdr entry)))
                          (throw 'done t))))
                    ;; if no rule matched, which should never happen,
                    ;; return to previous position so that forward
                    ;; progress is ensured
                    (goto-char prev))))
              (dolist (command muse-colors-delayed-commands)
                (apply (car command) (cdr command)))
              (run-hook-with-args 'muse-colors-buffer-hook
                                  beg end verbose)
              (if verbose (message "Highlighting buffer...done")))))
      (set-buffer-modified-p modified-p))))

(defcustom muse-colors-tags
  '(("example"  t nil nil muse-colors-example-tag)
    ("code"     t nil nil muse-colors-example-tag)
    ("verbatim" t nil nil muse-colors-literal-tag)
    ("lisp"     t t   nil muse-colors-lisp-tag)
    ("literal"  t nil nil muse-colors-literal-tag))
  "A list of tag specifications for specially highlighting text.
XML-style tags are the best way to add custom highlighting to Muse.
This is easily accomplished by customizing this list of markup tags.

For each entry, the name of the tag is given, whether it expects
a closing tag and/or an optional set of attributes, whether it is
nestable, and a function that performs whatever action is desired
within the delimited region.

The function is called with three arguments, the beginning and
end of the region surrounded by the tags. If properties are
allowed, they are passed as a third argument in the form of an
alist. The `end' argument to the function is the last character
of the enclosed tag or region.

Functions should not modify the contents of the buffer."
  :type '(repeat (list (string :tag "Markup tag")
                       (boolean :tag "Expect closing tag" :value t)
                       (boolean :tag "Parse attributes" :value nil)
                       (boolean :tag "Nestable" :value nil)
                       function))
  :group 'muse-colors)

(defvar muse-colors-inhibit-tags-in-directives t
  "If non-nil, don't allow tags to be interpreted in directives.
This is used to delay highlighting of <lisp> tags in #title until later.")
(make-variable-buffer-local 'muse-colors-inhibit-tags-in-directives)

(defsubst muse-colors-tag-info (tagname &rest args)
  "Get tag info associated with TAGNAME, ignoring ARGS."
  (assoc tagname muse-colors-tags))

(defun muse-colors-custom-tags ()
  "Highlight `muse-colors-tags'."
  (let ((tag-info (muse-colors-tag-info (match-string 1))))
    (unless (or (not tag-info)
                (get-text-property (match-beginning 0) 'muse-comment)
                (and muse-colors-inhibit-tags-in-directives
                     (get-text-property (match-beginning 0) 'muse-directive)))
      (let ((closed-tag (match-string 3))
            (start (match-beginning 0))
            end attrs)
        (when (nth 2 tag-info)
          (let ((attrstr (match-string 2)))
            (while (and attrstr
                        (string-match (concat "\\([^"
                                              muse-regexp-blank
                                              "=\n]+\\)\\(=\""
                                              "\\([^\"]+\\)\"\\)?")
                                      attrstr))
              (let ((attr (cons (downcase
                                 (muse-match-string-no-properties 1 attrstr))
                                (muse-match-string-no-properties 3 attrstr))))
                (setq attrstr (replace-match "" t t attrstr))
                (if attrs
                    (nconc attrs (list attr))
                  (setq attrs (list attr)))))))
        (if (and (cadr tag-info) (not closed-tag))
            (if (muse-goto-tag-end (car tag-info) (nth 3 tag-info))
                (setq end (match-end 0))
              (setq tag-info nil)))
        (when tag-info
          (let ((args (list start end)))
            (if (nth 2 tag-info)
                (nconc args (list attrs)))
            (apply (nth 4 tag-info) args)))))))

(defun muse-unhighlight-region (begin end &optional verbose)
  "Remove all visual highlights in the buffer (except font-lock)."
  (let ((buffer-undo-list t)
        (inhibit-read-only t)
        (inhibit-point-motion-hooks t)
        (inhibit-modification-hooks t)
        (modified-p (buffer-modified-p))
        deactivate-mark)
    (unwind-protect
        (remove-text-properties
         begin end '(face nil font-lock-multiline nil end-glyph nil
                          invisible nil intangible nil display nil
                          mouse-face nil keymap nil help-echo nil
                          muse-link nil muse-directive nil muse-comment nil
                          muse-no-implicit-link nil muse-no-flyspell nil))
      (set-buffer-modified-p modified-p))))

(defun muse-colors-example-tag (beg end)
  "Strip properties and colorize with `muse-verbatim'."
  (muse-unhighlight-region beg end)
  (let ((multi (save-excursion
                 (goto-char beg)
                 (forward-line 1)
                 (> end (point)))))
    (add-text-properties beg end `(face muse-verbatim
                                   font-lock-multiline ,multi))))

(defun muse-colors-literal-tag (beg end)
  "Strip properties and mark as literal."
  (muse-unhighlight-region beg end)
  (let ((multi (save-excursion
                 (goto-char beg)
                 (forward-line 1)
                 (> end (point)))))
    (add-text-properties beg end `(font-lock-multiline ,multi))))

(defun muse-colors-lisp-tag (beg end attrs)
  "Color the region enclosed by a <lisp> tag."
  (if (not muse-colors-evaluate-lisp-tags)
      (muse-colors-literal-tag beg end)
    (muse-unhighlight-region beg end)
    (let (beg-lisp end-lisp)
      (save-match-data
        (goto-char beg)
        (setq beg-lisp (and (looking-at "<[^>]+>")
                            (match-end 0)))
        (goto-char end)
        (setq end-lisp (and (muse-looking-back "</[^>]+>")
                            (match-beginning 0))))
      (add-text-properties
       beg end
       (list 'font-lock-multiline t
             'display (muse-eval-lisp
                       (concat
                        "(progn "
                        (buffer-substring-no-properties beg-lisp end-lisp)
                        ")"))
             'intangible t)))))

(defvar muse-mode-local-map
  (let ((map (make-sparse-keymap)))
    (define-key map [return] 'muse-follow-name-at-point)
    (define-key map [(control ?m)] 'muse-follow-name-at-point)
    (define-key map [(shift return)] 'muse-follow-name-at-point-other-window)
    (if (featurep 'xemacs)
        (progn
          (define-key map [(button2)] 'muse-follow-name-at-mouse)
          (define-key map [(shift button2)]
            'muse-follow-name-at-mouse-other-window))
      (define-key map [(shift control ?m)]
        'muse-follow-name-at-point-other-window)
      (define-key map [mouse-2] 'muse-follow-name-at-mouse)
      (define-key map [(shift mouse-2)]
        'muse-follow-name-at-mouse-other-window)
      (unless (eq emacs-major-version 21)
        (set-keymap-parent map muse-mode-map)))
    map)
  "Local keymap used by Muse while on a link.")

(defvar muse-keymap-property
  (if (or (featurep 'xemacs)
          (>= emacs-major-version 21))
      'keymap
    'local-map)
  "The name of the keymap or local-map property.")

(defsubst muse-link-properties (help-str &optional face)
  "Determine text properties to use for a link."
  (append (if face
              (list 'face face 'mouse-face 'highlight 'muse-link t)
            (list 'invisible 'muse 'intangible t))
          (list 'help-echo help-str 'rear-nonsticky t
                muse-keymap-property muse-mode-local-map)))

(defun muse-link-face (link-name &optional explicit)
  "Return the type of LINK-NAME as a face symbol.
For EXPLICIT links, this is either a normal link or a bad-link
face.  For implicit links, it is either colored normally or
ignored."
  (save-match-data
    (let ((link (if explicit
                    (muse-handle-explicit-link link-name)
                  (muse-handle-implicit-link link-name))))
      (when link
        (cond ((string-match muse-url-regexp link)
               'muse-link)
              ((muse-file-remote-p link)
               'muse-link)
              ((string-match muse-file-regexp link)
               (when (string-match "/[^/]+#[^#./]+\\'" link)
                 ;; strip anchor from the end of a path
                 (setq link (substring link 0 (match-beginning 0))))
               (if (file-exists-p link)
                   'muse-link
                 'muse-bad-link))
              ((not (featurep 'muse-project))
               'muse-link)
              (t
               (if (string-match "#" link)
                   (setq link (substring link 0 (match-beginning 0))))
               (if (or (and (muse-project-of-file)
                            (muse-project-page-file
                             link muse-current-project t))
                       (file-exists-p link))
                   'muse-link
                 'muse-bad-link)))))))

(defun muse-colors-use-publishing-directory (link)
  "Make LINK relative to the directory where we will publish the
current file."
  (let ((style (car (muse-project-applicable-styles
                     link (cddr (muse-project)))))
        path)
    (when (and style
               (setq path (muse-style-element :path style)))
      (expand-file-name link path))))

(defun muse-colors-resolve-image-file (link)
  "Determine if we can create images and see if the link is an image
file."
  (save-match-data
    (and (or (fboundp 'create-image)
             (fboundp 'make-glyph))
         (not (string-match "\\`[uU][rR][lL]:" link))
         (string-match muse-image-regexp link))))

(defun muse-make-file-glyph (filename)
  "Given a file name, return a newly-created image glyph.
This is a hack for supporting inline images in XEmacs."
  (let ((case-fold-search nil))
    ;; Scan filename to determine image type
    (when (fboundp 'make-glyph)
      (save-match-data
        (cond ((string-match "jpe?g" filename)
               (make-glyph (vector 'jpeg :file filename) 'buffer))
              ((string-match "gif" filename)
               (make-glyph (vector 'gif :file filename) 'buffer))
              ((string-match "png" filename)
               (make-glyph (vector 'png :file filename) 'buffer)))))))

(defun muse-colors-insert-image (link beg end invis-props)
  "Create an image using create-image or make-glyph and insert it
in place of an image link defined by BEG and END."
  (setq link (expand-file-name link))
  (let ((image-file (cond
                     ((eq muse-colors-inline-image-method 'default-directory)
                      link)
                     ((functionp muse-colors-inline-image-method)
                      (funcall muse-colors-inline-image-method link))))
        glyph)
    (when (stringp image-file)
      (if (fboundp 'create-image)
          ;; use create-image and display property
          (let ((display-stuff (condition-case nil
                                   (create-image image-file)
                                 (error nil))))
            (when display-stuff
              (add-text-properties beg end (list 'display display-stuff))))
        ;; use make-glyph and invisible property
        (and (setq glyph (muse-make-file-glyph image-file))
             (progn
               (add-text-properties beg end invis-props)
               (add-text-properties beg end (list
                                             'end-glyph glyph
                                             'help-echo link))))))))

(defun muse-colors-explicit-link ()
  "Color explicit links."
  (when (and (eq ?\[ (char-after (match-beginning 0)))
             (not (get-text-property (match-beginning 0) 'muse-comment))
             (not (get-text-property (match-beginning 0) 'muse-directive)))
    ;; remove flyspell overlays
    (when (fboundp 'flyspell-unhighlight-at)
      (let ((cur (match-beginning 0)))
        (while (> (match-end 0) cur)
          (flyspell-unhighlight-at cur)
          (setq cur (1+ cur)))))
    (let* ((unesc-link (muse-get-link))
           (unesc-desc (muse-get-link-desc))
           (link (muse-link-unescape unesc-link))
           (desc (muse-link-unescape unesc-desc))
           (props (muse-link-properties desc (muse-link-face link t)))
           (invis-props (append props (muse-link-properties desc))))
      ;; see if we should try and inline an image
      (if (and muse-colors-inline-images
               (or (muse-colors-resolve-image-file link)
                   (and desc
                        (muse-colors-resolve-image-file desc)
                        (setq link desc))))
          ;; we found an image, so inline it
          (muse-colors-insert-image
           link
           (match-beginning 0) (match-end 0) invis-props)
        (if desc
            (progn
              ;; we put the normal face properties on the invisible
              ;; portion too, since emacs sometimes will position
              ;; the cursor on an intangible character
              (add-text-properties (match-beginning 0)
                                   (match-beginning 2) invis-props)
              (add-text-properties (match-beginning 2) (match-end 2) props)
              (add-text-properties (match-end 2) (match-end 0) invis-props)
              ;; in case specials were escaped, cause the unescaped
              ;; text to be displayed
              (unless (string= desc unesc-desc)
                (add-text-properties (match-beginning 2) (match-end 2)
                                     (list 'display desc))))
          (add-text-properties (match-beginning 0)
                               (match-beginning 1) invis-props)
          (add-text-properties (match-beginning 1) (match-end 0) props)
          (add-text-properties (match-end 1) (match-end 0) invis-props)
          (unless (string= link unesc-link)
            (add-text-properties (match-beginning 1) (match-end 1)
                                 (list 'display link))))
        (goto-char (match-end 0))
        (add-text-properties
         (match-beginning 0) (match-end 0)
         (muse-link-properties (muse-match-string-no-properties 0)
                               (muse-link-face link t)))))))

(defun muse-colors-implicit-link ()
  "Color implicit links."
  (unless (or (eq (get-text-property (match-beginning 0) 'invisible) 'muse)
              (get-text-property (match-beginning 0) 'muse-comment)
              (get-text-property (match-beginning 0) 'muse-directive)
              (get-text-property (match-beginning 0) 'muse-no-implicit-link)
              (eq (char-before (match-beginning 0)) ?\")
              (eq (char-after (match-end 0)) ?\"))
    ;; remove flyspell overlays
    (when (fboundp 'flyspell-unhighlight-at)
      (let ((cur (match-beginning 0)))
        (while (> (match-end 0) cur)
          (flyspell-unhighlight-at cur)
          (setq cur (1+ cur)))))
    ;; colorize link
    (let ((link (muse-match-string-no-properties 0))
          (face (muse-link-face (match-string 0))))
      (when face
        (add-text-properties (match-beginning 0) (match-end 0)
                             (muse-link-properties
                              (muse-match-string-no-properties 0) face))))))

(defun muse-colors-title ()
  "Color #title directives."
  (let ((beg (+ 7 (match-beginning 0))))
    (add-text-properties beg (muse-line-end-position) '(muse-directive t))
    ;; colorize <lisp> tags in #title after other <lisp> tags have had a
    ;; chance to run, so that we can have behavior that is consistent
    ;; with how the document is published
    (setq muse-colors-delayed-commands
          (cons (list 'muse-colors-title-lisp beg (muse-line-end-position))
                muse-colors-delayed-commands))))

(defun muse-colors-title-lisp (beg end)
  "Called after other highlighting is done for a region in order to handle
<lisp> tags that exist in #title directives."
  (save-restriction
    (narrow-to-region beg end)
    (goto-char (point-min))
    (let ((muse-colors-inhibit-tags-in-directives nil)
          (muse-colors-tags '(("lisp" t t nil muse-colors-lisp-tag))))
      (while (re-search-forward muse-tag-regexp nil t)
        (muse-colors-custom-tags))))
  (add-text-properties beg end '(face muse-header-1)))

(defun muse-colors-comment ()
  "Color comments."
  (add-text-properties (match-beginning 0) (muse-line-end-position)
                       (list 'face 'font-lock-comment-face
                             'muse-comment t)))


(provide 'muse-colors)

;;; muse-colors.el ends here