--- /dev/null
+;;; 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
+ '((t :inherit link))
+ "Face for Muse cross-references."
+ :group 'muse-colors)
+
+(defface muse-bad-link
+ '((default :inherit 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