1020 lines
41 KiB
EmacsLisp
1020 lines
41 KiB
EmacsLisp
;;; 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
|