muse-latex: Make lecture notes and slides work with images, title page, TOC.
[muse-el.git] / lisp / muse-colors.el
blob03dd47b638007a2f5fa694b80050edf783e31d66
1 ;;; muse-colors.el --- coloring and highlighting used by Muse
3 ;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009
4 ;; Free Software Foundation, Inc.
6 ;; Author: John Wiegley (johnw AT gnu DOT org)
7 ;; Keywords: hypermedia
8 ;; Date: Thu 11-Mar-2004
10 ;; This file is part of Emacs Muse. It is not part of GNU Emacs.
12 ;; Emacs Muse is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published
14 ;; by the Free Software Foundation; either version 3, or (at your
15 ;; option) any later version.
17 ;; Emacs Muse is distributed in the hope that it will be useful, but
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;; General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with Emacs Muse; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25 ;; Boston, MA 02110-1301, USA.
27 ;;; Commentary:
29 ;;; Contributors:
31 ;; Lan Yufeng (nlany DOT web AT gmail DOT com) found an error where
32 ;; headings were being given the wrong face, contributing a patch to
33 ;; fix this.
35 ;; Sergey Vlasov (vsu AT altlinux DOT ru) fixed an issue with coloring
36 ;; links that are in consecutive lines.
38 ;; Jim Ottaway ported the <lisp> tag from emacs-wiki.
40 ;; Per B. Sederberg (per AT med DOT upenn DOT edu) contributed the
41 ;; viewing of inline images.
43 ;;; Code:
45 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
47 ;; Emacs Muse Highlighting
49 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51 (require 'muse-mode)
52 (require 'muse-regexps)
53 (require 'font-lock)
55 (defgroup muse-colors nil
56 "Options controlling the behavior of Emacs Muse highlighting.
57 See `muse-colors-buffer' for more information."
58 :group 'muse-mode)
60 (defcustom muse-colors-autogen-headings t
61 "Specify whether the heading faces should be auto-generated.
62 The default is to scale them.
64 Choosing 'outline will copy the colors from the outline-mode
65 headings.
67 If you want to customize each of the headings individually, set
68 this to nil."
69 :type '(choice (const :tag "Default (scaled) headings" t)
70 (const :tag "Use outline-mode headings" outline)
71 (const :tag "Don't touch the headings" nil))
72 :group 'muse-colors)
74 (defcustom muse-colors-evaluate-lisp-tags t
75 "Specify whether to evaluate the contents of <lisp> tags at
76 display time. If nil, don't evaluate them. If non-nil, evaluate
77 them.
79 The actual contents of the buffer are not changed, only the
80 displayed text."
81 :type 'boolean
82 :group 'muse-colors)
84 (defcustom muse-colors-inline-images t
85 "Specify whether to inline images inside the Emacs buffer. If
86 nil, don't inline them. If non-nil, an image link will be
87 replaced by the image.
89 The actual contents of the buffer are not changed, only whether
90 an image is displayed."
91 :type 'boolean
92 :group 'muse-colors)
94 (defcustom muse-colors-inline-image-method 'default-directory
95 "Determine how to locate inline images.
96 Setting this to 'default-directory uses the current directory of
97 the current Muse buffer.
99 Setting this to a function calls that function with the filename
100 of the image to be inlined. The value that is returned will be
101 used as the filename of the image."
102 :type '(choice (const :tag "Current directory" default-directory)
103 (const :tag "Publishing directory"
104 muse-colors-use-publishing-directory)
105 (function :tag "Custom function"))
106 :group 'muse-colors)
108 (defvar muse-colors-region-end nil
109 "Indicate the end of the region that is currently being font-locked.")
110 (make-variable-buffer-local 'muse-colors-region-end)
112 ;;;###autoload
113 (defun muse-colors-toggle-inline-images ()
114 "Toggle display of inlined images on/off."
115 (interactive)
116 ;; toggle the custom setting
117 (if (not muse-colors-inline-images)
118 (setq muse-colors-inline-images t)
119 (setq muse-colors-inline-images nil))
120 ;; reprocess the buffer
121 (muse-colors-buffer)
122 ;; display informative message
123 (if muse-colors-inline-images
124 (message "Images are now displayed inline")
125 (message "Images are now displayed as links")))
127 (defvar muse-colors-outline-faces-list
128 (if (facep 'outline-1)
129 '(outline-1 outline-2 outline-3 outline-4 outline-5)
130 ;; these are equivalent in coloring to the outline faces
131 '(font-lock-function-name-face
132 font-lock-variable-name-face
133 font-lock-keyword-face
134 font-lock-builtin-face
135 font-lock-comment-face))
136 "Outline faces to use when assigning Muse header faces.")
138 (defun muse-make-faces-default (&optional later)
139 "Generate the default face definitions for headers."
140 (dolist (num '(1 2 3 4 5))
141 (let ((newsym (intern (concat "muse-header-" (int-to-string num))))
142 (docstring (concat
143 "Muse header face. See "
144 "`muse-colors-autogen-headings' before changing it.")))
145 ;; put in the proper group and give documentation
146 (if later
147 (unless (featurep 'xemacs)
148 (muse-copy-face 'variable-pitch newsym)
149 (set-face-attribute newsym nil :height (1+ (* 0.1 (- 5 num)))
150 :weight 'bold))
151 (if (featurep 'xemacs)
152 (eval `(defface ,newsym
153 '((t (:size
154 ,(nth (1- num)
155 '("24pt" "18pt" "14pt" "12pt" "11pt"))
156 :bold t)))
157 ,docstring
158 :group 'muse-colors))
159 (eval `(defface ,newsym
160 '((t (:height ,(1+ (* 0.1 (- 5 num)))
161 :inherit variable-pitch
162 :weight bold)))
163 ,docstring
164 :group 'muse-colors)))))))
166 (progn (muse-make-faces-default))
168 (defun muse-make-faces (&optional frame)
169 "Generate face definitions for headers based the user's preferences."
170 (cond
171 ((not muse-colors-autogen-headings)
172 nil)
173 ((eq muse-colors-autogen-headings t)
174 (muse-make-faces-default t))
176 (dolist (num '(1 2 3 4 5))
177 (let ((newsym (intern (concat "muse-header-" (int-to-string num)))))
178 ;; copy the desired face definition
179 (muse-copy-face (nth (1- num) muse-colors-outline-faces-list)
180 newsym))))))
182 ;; after displaying the Emacs splash screen, the faces are wiped out,
183 ;; so recover from that
184 (add-hook 'window-setup-hook #'muse-make-faces)
185 ;; ditto for when a new frame is created
186 (when (boundp 'after-make-frame-functions)
187 (add-hook 'after-make-frame-functions #'muse-make-faces))
189 (defface muse-link
190 '((((class color) (background light))
191 (:foreground "blue" :underline "blue" :bold t))
192 (((class color) (background dark))
193 (:foreground "cyan" :underline "cyan" :bold t))
194 (t (:bold t)))
195 "Face for Muse cross-references."
196 :group 'muse-colors)
198 (defface muse-bad-link
199 '((((class color) (background light))
200 (:foreground "red" :underline "red" :bold t))
201 (((class color) (background dark))
202 (:foreground "coral" :underline "coral" :bold t))
203 (t (:bold t)))
204 "Face for bad Muse cross-references."
205 :group 'muse-colors)
207 (defface muse-verbatim
208 '((((class color) (background light))
209 (:foreground "slate gray"))
210 (((class color) (background dark))
211 (:foreground "gray")))
212 "Face for verbatim text."
213 :group 'muse-colors)
215 (defface muse-emphasis-1
216 '((t (:italic t)))
217 "Face for italic emphasized text."
218 :group 'muse-colors)
220 (defface muse-emphasis-2
221 '((t (:bold t)))
222 "Face for bold emphasized text."
223 :group 'muse-colors)
225 (defface muse-emphasis-3
226 '((t (:bold t :italic t)))
227 "Face for bold italic emphasized text."
228 :group 'muse-colors)
230 (muse-copy-face 'italic 'muse-emphasis-1)
231 (muse-copy-face 'bold 'muse-emphasis-2)
232 (muse-copy-face 'bold-italic 'muse-emphasis-3)
234 (defcustom muse-colors-buffer-hook nil
235 "A hook run after a region is highlighted.
236 Each function receives three arguments: BEG END VERBOSE.
237 BEG and END mark the range being highlighted, and VERBOSE specifies
238 whether progress messages should be displayed to the user."
239 :type 'hook
240 :group 'muse-colors)
242 (defvar muse-colors-highlighting-registry nil
243 "The rules for highlighting Muse and Muse-derived buffers.
244 This is automatically generated when using font-lock in Muse buffers.
246 This an alist of major-mode symbols to `muse-colors-rule' objects.")
248 (defun muse-colors-make-highlighting-struct ()
249 (list nil nil nil))
250 (defconst muse-colors-highlighting.regexp 0
251 "Regexp matching each car of the markup of the current rule.")
252 (defconst muse-colors-highlighting.vector 1
253 "Vector of all characters that are part of the markup of the current rule.
254 This is composed of the 2nd element of each markup entry.")
255 (defconst muse-colors-highlighting.remaining 2
256 "Expressions for highlighting a buffer which have no corresponding
257 entry in the vector.")
259 (defsubst muse-colors-highlighting-entry (mode)
260 "Return the highlighting rules for MODE."
261 (assq mode muse-colors-highlighting-registry))
263 (defun muse-colors-find-highlighting (mode)
264 "Return the highlighting rules to be used for MODE.
265 If MODE does not have highlighting rules, check its parent modes."
266 (let ((seen nil))
267 (catch 'rules
268 (while (and mode (not (memq mode seen)))
269 (let ((entry (muse-colors-highlighting-entry mode)))
270 (when entry (throw 'rules (cdr entry))))
271 (setq seen (cons mode seen))
272 (setq mode (get mode 'derived-mode-parent)))
273 nil)))
275 (defun muse-colors-define-highlighting (mode markup)
276 "Create or update the markup rules for MODE, using MARKUP.
278 See `muse-colors-markup' for an explanation of the format that MARKUP
279 should take."
280 (unless (and (symbolp mode) mode (consp markup))
281 (error "Invalid arguments"))
282 (let* ((highlighting-entry (muse-colors-highlighting-entry mode))
283 (struct (cdr highlighting-entry))
284 (regexp nil)
285 (vector nil)
286 (remaining nil))
287 ;; Initialize struct
288 (if struct
289 (setq vector (nth muse-colors-highlighting.vector struct))
290 (setq struct (muse-colors-make-highlighting-struct)))
291 ;; Initialize vector
292 (if vector
293 (let ((i 0))
294 (while (< i 128)
295 (aset vector i nil)
296 (setq i (1+ i))))
297 (setq vector (make-vector 128 nil)))
298 ;; Determine vector, regexp, remaining
299 (let ((regexps nil)
300 (rules nil))
301 (dolist (rule markup)
302 (let ((value (cond ((symbolp (car rule))
303 (symbol-value (car rule)))
304 ((stringp (car rule))
305 (car rule))
306 (t nil))))
307 (when value
308 (setq rules (cons rule rules))
309 (setq regexps (cons value regexps)))))
310 (setq regexps (nreverse regexps))
311 (setq regexp (concat "\\(" (mapconcat #'identity regexps "\\|") "\\)"))
312 (dolist (rule rules)
313 (if (eq (nth 1 rule) t)
314 (setq remaining (cons (cons (nth 0 rule) (nth 2 rule))
315 remaining))
316 (aset vector (nth 1 rule)
317 (cons (cons (nth 0 rule) (nth 2 rule))
318 (aref vector (nth 1 rule)))))))
319 ;; Update the struct
320 (setcar (nthcdr muse-colors-highlighting.regexp struct) regexp)
321 (setcar (nthcdr muse-colors-highlighting.vector struct) vector)
322 (setcar (nthcdr muse-colors-highlighting.remaining struct) remaining)
323 ;; Update entry for mode in muse-colors-highlighting-registry
324 (if highlighting-entry
325 (setcdr highlighting-entry struct)
326 (setq muse-colors-highlighting-registry
327 (cons (cons mode struct)
328 muse-colors-highlighting-registry)))))
330 (defun muse-configure-highlighting (sym val)
331 "Extract color markup information from VAL and set to SYM.
332 This is usually called with `muse-colors-markup' as both arguments."
333 (muse-colors-define-highlighting 'muse-mode val)
334 (set sym val))
336 (defun muse-colors-emphasized ()
337 "Color emphasized text and headings."
338 ;; Here we need to check four different points - the start and end
339 ;; of the leading *s, and the start and end of the trailing *s. We
340 ;; allow the outsides to be surrounded by whitespace or punctuation,
341 ;; but no word characters, and the insides must not be surrounded by
342 ;; whitespace or punctuation. Thus the following are valid:
344 ;; " *foo bar* "
345 ;; "**foo**,"
346 ;; and the following is invalid:
347 ;; "** testing **"
348 (let* ((beg (match-beginning 0))
349 (e1 (match-end 0))
350 (leader (- e1 beg))
351 b2 e2 multiline)
352 (unless (or (eq (get-text-property beg 'invisible) 'muse)
353 (get-text-property beg 'muse-comment)
354 (get-text-property beg 'muse-directive))
355 ;; check if it's a header
356 (if (eq (char-after e1) ?\ )
357 (when (or (= beg (point-min))
358 (eq (char-before beg) ?\n))
359 (add-text-properties
360 (muse-line-beginning-position) (muse-line-end-position)
361 (list 'face (intern (concat "muse-header-"
362 (int-to-string leader))))))
363 ;; beginning of line or space or symbol
364 (when (or (= beg (point-min))
365 (eq (char-syntax (char-before beg)) ?\ )
366 (memq (char-before beg)
367 '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
368 (save-excursion
369 (skip-chars-forward "^*<>\n" muse-colors-region-end)
370 (when (eq (char-after) ?\n)
371 (setq multiline t)
372 (skip-chars-forward "^*<>" muse-colors-region-end))
373 (setq b2 (point))
374 (skip-chars-forward "*" muse-colors-region-end)
375 (setq e2 (point))
376 ;; Abort if space exists just before end
377 ;; or bad leader
378 ;; or no '*' at end
379 ;; or word constituent follows
380 (unless (or (> leader 5)
381 (not (eq leader (- e2 b2)))
382 (eq (char-syntax (char-before b2)) ?\ )
383 (not (eq (char-after b2) ?*))
384 (and (not (eobp))
385 (eq (char-syntax (char-after (1+ b2))) ?w)))
386 (add-text-properties beg e1 '(invisible muse))
387 (add-text-properties
388 e1 b2 (list 'face (cond ((= leader 1) 'muse-emphasis-1)
389 ((= leader 2) 'muse-emphasis-2)
390 ((= leader 3) 'muse-emphasis-3))))
391 (add-text-properties b2 e2 '(invisible muse))
392 (when multiline
393 (add-text-properties
394 beg e2 '(font-lock-multiline t))))))))))
396 (defun muse-colors-underlined ()
397 "Color underlined text."
398 (let ((start (match-beginning 0))
399 multiline)
400 (unless (or (eq (get-text-property start 'invisible) 'muse)
401 (get-text-property start 'muse-comment)
402 (get-text-property start 'muse-directive))
403 ;; beginning of line or space or symbol
404 (when (or (= start (point-min))
405 (eq (char-syntax (char-before start)) ?\ )
406 (memq (char-before start)
407 '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
408 (save-excursion
409 (skip-chars-forward "^_<>\n" muse-colors-region-end)
410 (when (eq (char-after) ?\n)
411 (setq multiline t)
412 (skip-chars-forward "^_<>" muse-colors-region-end))
413 ;; Abort if space exists just before end
414 ;; or no '_' at end
415 ;; or word constituent follows
416 (unless (or (eq (char-syntax (char-before (point))) ?\ )
417 (not (eq (char-after (point)) ?_))
418 (and (not (eobp))
419 (eq (char-syntax (char-after (1+ (point)))) ?w)))
420 (add-text-properties start (1+ start) '(invisible muse))
421 (add-text-properties (1+ start) (point) '(face underline))
422 (add-text-properties (point)
423 (min (1+ (point)) (point-max))
424 '(invisible muse))
425 (when multiline
426 (add-text-properties
427 start (min (1+ (point)) (point-max))
428 '(font-lock-multiline t)))))))))
430 (defun muse-colors-verbatim ()
431 "Render in teletype and suppress further parsing."
432 (let ((start (match-beginning 0))
433 multiline)
434 (unless (or (eq (get-text-property start 'invisible) 'muse)
435 (get-text-property start 'muse-comment)
436 (get-text-property start 'muse-directive))
437 ;; beginning of line or space or symbol
438 (when (or (= start (point-min))
439 (eq (char-syntax (char-before start)) ?\ )
440 (memq (char-before start)
441 '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
442 (let ((pos (point)))
443 (skip-chars-forward "^=\n" muse-colors-region-end)
444 (when (eq (char-after) ?\n)
445 (setq multiline t)
446 (skip-chars-forward "^=" muse-colors-region-end))
447 ;; Abort if space exists just before end
448 ;; or no '=' at end
449 ;; or word constituent follows
450 (unless (or (eq (char-syntax (char-before (point))) ?\ )
451 (not (eq (char-after (point)) ?=))
452 (and (not (eobp))
453 (eq (char-syntax (char-after (1+ (point)))) ?w)))
454 (setq pos (min (1+ (point)) (point-max)))
455 (add-text-properties start (1+ start) '(invisible muse))
456 (add-text-properties (1+ start) (point) '(face muse-verbatim))
457 (add-text-properties (point)
458 (min (1+ (point)) (point-max))
459 '(invisible muse))
460 (when multiline
461 (add-text-properties
462 start (min (1+ (point)) (point-max))
463 '(font-lock-multiline t))))
464 (goto-char pos))))))
466 (defcustom muse-colors-markup
467 `(;; make emphasized text appear emphasized
468 ("\\*\\{1,5\\}" ?* muse-colors-emphasized)
470 ;; make underlined text appear underlined
471 (,(concat "_[^" muse-regexp-blank "_\n]")
472 ?_ muse-colors-underlined)
474 ("^#title " ?\# muse-colors-title)
476 (muse-explicit-link-regexp ?\[ muse-colors-explicit-link)
478 ;; render in teletype and suppress further parsing
479 (,(concat "=[^" muse-regexp-blank "=\n]") ?= muse-colors-verbatim)
481 ;; highlight any markup tags encountered
482 (muse-tag-regexp ?\< muse-colors-custom-tags)
484 ;; display comments
485 (,(concat "^;[" muse-regexp-blank "]") ?\; muse-colors-comment)
487 ;; this has to come later since it doesn't have a special
488 ;; character in the second cell
489 (muse-url-regexp t muse-colors-implicit-link)
491 "Expressions to highlight an Emacs Muse buffer.
492 These are arranged in a rather special fashion, so as to be as quick as
493 possible.
495 Each element of the list is itself a list, of the form:
497 (LOCATE-REGEXP TEST-CHAR MATCH-FUNCTION)
499 LOCATE-REGEXP is a partial regexp, and should be the smallest possible
500 regexp to differentiate this rule from other rules. It may also be a
501 symbol containing such a regexp. The buffer region is scanned only
502 once, and LOCATE-REGEXP indicates where the scanner should stop to
503 look for highlighting possibilities.
505 TEST-CHAR is a char or t. The character should match the beginning
506 text matched by LOCATE-REGEXP. These chars are used to build a vector
507 for fast MATCH-FUNCTION calling.
509 MATCH-FUNCTION is the function called when a region has been
510 identified. It is responsible for adding the appropriate text
511 properties to change the appearance of the buffer.
513 This markup is used to modify the appearance of the original text to
514 make it look more like the published HTML would look (like making some
515 markup text invisible, inlining images, etc).
517 font-lock is used to apply the markup rules, so that they can happen
518 on a deferred basis. They are not always accurate, but you can use
519 \\[font-lock-fontifty-block] near the point of error to force
520 fontification in that area."
521 :type '(repeat
522 (list :tag "Highlight rule"
523 (choice (regexp :tag "Locate regexp")
524 (symbol :tag "Regexp symbol"))
525 (choice (character :tag "Confirm character")
526 (const :tag "Default rule" t))
527 function))
528 :set 'muse-configure-highlighting
529 :group 'muse-colors)
531 ;; XEmacs users don't have `font-lock-multiline'.
532 (unless (boundp 'font-lock-multiline)
533 (defvar font-lock-multiline nil))
535 (defun muse-use-font-lock ()
536 "Set up font-locking for Muse."
537 (muse-add-to-invisibility-spec 'muse)
538 (set (make-local-variable 'font-lock-multiline) 'undecided)
539 (set (make-local-variable 'font-lock-defaults)
540 `(nil t nil nil beginning-of-line
541 (font-lock-fontify-region-function . muse-colors-region)
542 (font-lock-unfontify-region-function
543 . muse-unhighlight-region)))
544 (set (make-local-variable 'font-lock-fontify-region-function)
545 'muse-colors-region)
546 (set (make-local-variable 'font-lock-unfontify-region-function)
547 'muse-unhighlight-region)
548 (muse-make-faces)
549 (muse-colors-define-highlighting 'muse-mode muse-colors-markup)
550 (font-lock-mode t))
552 (defun muse-colors-buffer ()
553 "Re-highlight the entire Muse buffer."
554 (interactive)
555 (muse-colors-region (point-min) (point-max) t))
557 (defvar muse-colors-fontifying-p nil
558 "Indicate whether Muse is fontifying the current buffer.")
559 (make-variable-buffer-local 'muse-colors-fontifying-p)
561 (defvar muse-colors-delayed-commands nil
562 "Commands to be run immediately after highlighting a region.
564 This is meant to accommodate highlighting <lisp> in #title
565 directives after everything else.
567 It may be modified by Muse functions during highlighting, but not
568 the user.")
569 (make-variable-buffer-local 'muse-colors-delayed-commands)
571 (defun muse-colors-region (beg end &optional verbose)
572 "Apply highlighting according to `muse-colors-markup'.
573 Note that this function should NOT change the buffer, nor should any
574 of the functions listed in `muse-colors-markup'."
575 (let ((buffer-undo-list t)
576 (inhibit-read-only t)
577 (inhibit-point-motion-hooks t)
578 (inhibit-modification-hooks t)
579 (modified-p (buffer-modified-p))
580 (muse-colors-fontifying-p t)
581 (muse-colors-region-end (muse-line-end-position end))
582 (muse-colors-delayed-commands nil)
583 (highlighting (muse-colors-find-highlighting major-mode))
584 regexp vector remaining
585 deactivate-mark)
586 (unless highlighting
587 (error "No highlighting found for this mode"))
588 (setq regexp (nth muse-colors-highlighting.regexp highlighting)
589 vector (nth muse-colors-highlighting.vector highlighting)
590 remaining (nth muse-colors-highlighting.remaining highlighting))
591 (unwind-protect
592 (save-excursion
593 (save-restriction
594 (widen)
595 ;; check to see if we should expand the beg/end area for
596 ;; proper multiline matches
597 (when (and font-lock-multiline
598 (> beg (point-min))
599 (get-text-property (1- beg) 'font-lock-multiline))
600 ;; We are just after or in a multiline match.
601 (setq beg (or (previous-single-property-change
602 beg 'font-lock-multiline)
603 (point-min)))
604 (goto-char beg)
605 (setq beg (muse-line-beginning-position)))
606 (when font-lock-multiline
607 (setq end (or (text-property-any end (point-max)
608 'font-lock-multiline nil)
609 (point-max))))
610 (goto-char end)
611 (setq end (muse-line-beginning-position 2))
612 ;; Undo any fontification in the area.
613 (font-lock-unfontify-region beg end)
614 ;; And apply fontification based on `muse-colors-markup'
615 (let ((len (float (- end beg)))
616 (case-fold-search nil)
617 markup-list)
618 (goto-char beg)
619 (while (and (< (point) end)
620 (re-search-forward regexp end t))
621 (if verbose
622 (message "Highlighting buffer...%d%%"
623 (* (/ (float (- (point) beg)) len) 100)))
624 (let ((ch (char-after (match-beginning 0))))
625 (when (< ch 128)
626 (setq markup-list (aref vector ch))))
627 (unless markup-list
628 (setq markup-list remaining))
629 (let ((prev (point)))
630 ;; backtrack and figure out which rule matched
631 (goto-char (match-beginning 0))
632 (catch 'done
633 (dolist (entry markup-list)
634 (let ((value (cond ((symbolp (car entry))
635 (symbol-value (car entry)))
636 ((stringp (car entry))
637 (car entry))
638 (t nil))))
639 (when (and (stringp value) (looking-at value))
640 (goto-char (match-end 0))
641 (when (cdr entry)
642 (funcall (cdr entry)))
643 (throw 'done t))))
644 ;; if no rule matched, which should never happen,
645 ;; return to previous position so that forward
646 ;; progress is ensured
647 (goto-char prev))))
648 (dolist (command muse-colors-delayed-commands)
649 (apply (car command) (cdr command)))
650 (run-hook-with-args 'muse-colors-buffer-hook
651 beg end verbose)
652 (if verbose (message "Highlighting buffer...done")))))
653 (set-buffer-modified-p modified-p))))
655 (defcustom muse-colors-tags
656 '(("example" t nil nil muse-colors-example-tag)
657 ("code" t nil nil muse-colors-example-tag)
658 ("verbatim" t nil nil muse-colors-literal-tag)
659 ("lisp" t t nil muse-colors-lisp-tag)
660 ("literal" t nil nil muse-colors-literal-tag))
661 "A list of tag specifications for specially highlighting text.
662 XML-style tags are the best way to add custom highlighting to Muse.
663 This is easily accomplished by customizing this list of markup tags.
665 For each entry, the name of the tag is given, whether it expects
666 a closing tag and/or an optional set of attributes, whether it is
667 nestable, and a function that performs whatever action is desired
668 within the delimited region.
670 The function is called with three arguments, the beginning and
671 end of the region surrounded by the tags. If properties are
672 allowed, they are passed as a third argument in the form of an
673 alist. The `end' argument to the function is the last character
674 of the enclosed tag or region.
676 Functions should not modify the contents of the buffer."
677 :type '(repeat (list (string :tag "Markup tag")
678 (boolean :tag "Expect closing tag" :value t)
679 (boolean :tag "Parse attributes" :value nil)
680 (boolean :tag "Nestable" :value nil)
681 function))
682 :group 'muse-colors)
684 (defvar muse-colors-inhibit-tags-in-directives t
685 "If non-nil, don't allow tags to be interpreted in directives.
686 This is used to delay highlighting of <lisp> tags in #title until later.")
687 (make-variable-buffer-local 'muse-colors-inhibit-tags-in-directives)
689 (defsubst muse-colors-tag-info (tagname &rest args)
690 "Get tag info associated with TAGNAME, ignoring ARGS."
691 (assoc tagname muse-colors-tags))
693 (defun muse-colors-custom-tags ()
694 "Highlight `muse-colors-tags'."
695 (let ((tag-info (muse-colors-tag-info (match-string 1))))
696 (unless (or (not tag-info)
697 (get-text-property (match-beginning 0) 'muse-comment)
698 (and muse-colors-inhibit-tags-in-directives
699 (get-text-property (match-beginning 0) 'muse-directive)))
700 (let ((closed-tag (match-string 3))
701 (start (match-beginning 0))
702 end attrs)
703 (when (nth 2 tag-info)
704 (let ((attrstr (match-string 2)))
705 (while (and attrstr
706 (string-match (concat "\\([^"
707 muse-regexp-blank
708 "=\n]+\\)\\(=\""
709 "\\([^\"]+\\)\"\\)?")
710 attrstr))
711 (let ((attr (cons (downcase
712 (muse-match-string-no-properties 1 attrstr))
713 (muse-match-string-no-properties 3 attrstr))))
714 (setq attrstr (replace-match "" t t attrstr))
715 (if attrs
716 (nconc attrs (list attr))
717 (setq attrs (list attr)))))))
718 (if (and (cadr tag-info) (not closed-tag))
719 (if (muse-goto-tag-end (car tag-info) (nth 3 tag-info))
720 (setq end (match-end 0))
721 (setq tag-info nil)))
722 (when tag-info
723 (let ((args (list start end)))
724 (if (nth 2 tag-info)
725 (nconc args (list attrs)))
726 (apply (nth 4 tag-info) args)))))))
728 (defun muse-unhighlight-region (begin end &optional verbose)
729 "Remove all visual highlights in the buffer (except font-lock)."
730 (let ((buffer-undo-list t)
731 (inhibit-read-only t)
732 (inhibit-point-motion-hooks t)
733 (inhibit-modification-hooks t)
734 (modified-p (buffer-modified-p))
735 deactivate-mark)
736 (unwind-protect
737 (remove-text-properties
738 begin end '(face nil font-lock-multiline nil end-glyph nil
739 invisible nil intangible nil display nil
740 mouse-face nil keymap nil help-echo nil
741 muse-link nil muse-directive nil muse-comment nil
742 muse-no-implicit-link nil muse-no-flyspell nil))
743 (set-buffer-modified-p modified-p))))
745 (defun muse-colors-example-tag (beg end)
746 "Strip properties and colorize with `muse-verbatim'."
747 (muse-unhighlight-region beg end)
748 (let ((multi (save-excursion
749 (goto-char beg)
750 (forward-line 1)
751 (> end (point)))))
752 (add-text-properties beg end `(face muse-verbatim
753 font-lock-multiline ,multi))))
755 (defun muse-colors-literal-tag (beg end)
756 "Strip properties and mark as literal."
757 (muse-unhighlight-region beg end)
758 (let ((multi (save-excursion
759 (goto-char beg)
760 (forward-line 1)
761 (> end (point)))))
762 (add-text-properties beg end `(font-lock-multiline ,multi))))
764 (defun muse-colors-lisp-tag (beg end attrs)
765 "Color the region enclosed by a <lisp> tag."
766 (if (not muse-colors-evaluate-lisp-tags)
767 (muse-colors-literal-tag beg end)
768 (muse-unhighlight-region beg end)
769 (let (beg-lisp end-lisp)
770 (save-match-data
771 (goto-char beg)
772 (setq beg-lisp (and (looking-at "<[^>]+>")
773 (match-end 0)))
774 (goto-char end)
775 (setq end-lisp (and (muse-looking-back "</[^>]+>")
776 (match-beginning 0))))
777 (add-text-properties
778 beg end
779 (list 'font-lock-multiline t
780 'display (muse-eval-lisp
781 (concat
782 "(progn "
783 (buffer-substring-no-properties beg-lisp end-lisp)
784 ")"))
785 'intangible t)))))
787 (defvar muse-mode-local-map
788 (let ((map (make-sparse-keymap)))
789 (define-key map [return] 'muse-follow-name-at-point)
790 (define-key map [(control ?m)] 'muse-follow-name-at-point)
791 (define-key map [(shift return)] 'muse-follow-name-at-point-other-window)
792 (if (featurep 'xemacs)
793 (progn
794 (define-key map [(button2)] 'muse-follow-name-at-mouse)
795 (define-key map [(shift button2)]
796 'muse-follow-name-at-mouse-other-window))
797 (define-key map [(shift control ?m)]
798 'muse-follow-name-at-point-other-window)
799 (define-key map [mouse-2] 'muse-follow-name-at-mouse)
800 (define-key map [(shift mouse-2)]
801 'muse-follow-name-at-mouse-other-window)
802 (unless (eq emacs-major-version 21)
803 (set-keymap-parent map muse-mode-map)))
804 map)
805 "Local keymap used by Muse while on a link.")
807 (defvar muse-keymap-property
808 (if (or (featurep 'xemacs)
809 (>= emacs-major-version 21))
810 'keymap
811 'local-map)
812 "The name of the keymap or local-map property.")
814 (defsubst muse-link-properties (help-str &optional face)
815 "Determine text properties to use for a link."
816 (append (if face
817 (list 'face face 'mouse-face 'highlight 'muse-link t)
818 (list 'invisible 'muse 'intangible t))
819 (list 'help-echo help-str 'rear-nonsticky t
820 muse-keymap-property muse-mode-local-map)))
822 (defun muse-link-face (link-name &optional explicit)
823 "Return the type of LINK-NAME as a face symbol.
824 For EXPLICIT links, this is either a normal link or a bad-link
825 face. For implicit links, it is either colored normally or
826 ignored."
827 (save-match-data
828 (let ((link (if explicit
829 (muse-handle-explicit-link link-name)
830 (muse-handle-implicit-link link-name))))
831 (when link
832 (cond ((string-match muse-url-regexp link)
833 'muse-link)
834 ((muse-file-remote-p link)
835 'muse-link)
836 ((string-match muse-file-regexp link)
837 (when (string-match "/[^/]+#[^#./]+\\'" link)
838 ;; strip anchor from the end of a path
839 (setq link (substring link 0 (match-beginning 0))))
840 (if (file-exists-p link)
841 'muse-link
842 'muse-bad-link))
843 ((not (featurep 'muse-project))
844 'muse-link)
846 (if (string-match "#" link)
847 (setq link (substring link 0 (match-beginning 0))))
848 (if (or (and (muse-project-of-file)
849 (muse-project-page-file
850 link muse-current-project t))
851 (file-exists-p link))
852 'muse-link
853 'muse-bad-link)))))))
855 (defun muse-colors-use-publishing-directory (link)
856 "Make LINK relative to the directory where we will publish the
857 current file."
858 (let ((style (car (muse-project-applicable-styles
859 link (cddr (muse-project)))))
860 path)
861 (when (and style
862 (setq path (muse-style-element :path style)))
863 (expand-file-name link path))))
865 (defun muse-colors-resolve-image-file (link)
866 "Determine if we can create images and see if the link is an image
867 file."
868 (save-match-data
869 (and (or (fboundp 'create-image)
870 (fboundp 'make-glyph))
871 (not (string-match "\\`[uU][rR][lL]:" link))
872 (string-match muse-image-regexp link))))
874 (defun muse-make-file-glyph (filename)
875 "Given a file name, return a newly-created image glyph.
876 This is a hack for supporting inline images in XEmacs."
877 (let ((case-fold-search nil))
878 ;; Scan filename to determine image type
879 (when (fboundp 'make-glyph)
880 (save-match-data
881 (cond ((string-match "jpe?g" filename)
882 (make-glyph (vector 'jpeg :file filename) 'buffer))
883 ((string-match "gif" filename)
884 (make-glyph (vector 'gif :file filename) 'buffer))
885 ((string-match "png" filename)
886 (make-glyph (vector 'png :file filename) 'buffer)))))))
888 (defun muse-colors-insert-image (link beg end invis-props)
889 "Create an image using create-image or make-glyph and insert it
890 in place of an image link defined by BEG and END."
891 (setq link (expand-file-name link))
892 (let ((image-file (cond
893 ((eq muse-colors-inline-image-method 'default-directory)
894 link)
895 ((functionp muse-colors-inline-image-method)
896 (funcall muse-colors-inline-image-method link))))
897 glyph)
898 (when (stringp image-file)
899 (if (fboundp 'create-image)
900 ;; use create-image and display property
901 (let ((display-stuff (condition-case nil
902 (create-image image-file)
903 (error nil))))
904 (when display-stuff
905 (add-text-properties beg end (list 'display display-stuff))))
906 ;; use make-glyph and invisible property
907 (and (setq glyph (muse-make-file-glyph image-file))
908 (progn
909 (add-text-properties beg end invis-props)
910 (add-text-properties beg end (list
911 'end-glyph glyph
912 'help-echo link))))))))
914 (defun muse-colors-explicit-link ()
915 "Color explicit links."
916 (when (and (eq ?\[ (char-after (match-beginning 0)))
917 (not (get-text-property (match-beginning 0) 'muse-comment))
918 (not (get-text-property (match-beginning 0) 'muse-directive)))
919 ;; remove flyspell overlays
920 (when (fboundp 'flyspell-unhighlight-at)
921 (let ((cur (match-beginning 0)))
922 (while (> (match-end 0) cur)
923 (flyspell-unhighlight-at cur)
924 (setq cur (1+ cur)))))
925 (let* ((unesc-link (muse-get-link))
926 (unesc-desc (muse-get-link-desc))
927 (link (muse-link-unescape unesc-link))
928 (desc (muse-link-unescape unesc-desc))
929 (props (muse-link-properties desc (muse-link-face link t)))
930 (invis-props (append props (muse-link-properties desc))))
931 ;; see if we should try and inline an image
932 (if (and muse-colors-inline-images
933 (or (muse-colors-resolve-image-file link)
934 (and desc
935 (muse-colors-resolve-image-file desc)
936 (setq link desc))))
937 ;; we found an image, so inline it
938 (muse-colors-insert-image
939 link
940 (match-beginning 0) (match-end 0) invis-props)
941 (if desc
942 (progn
943 ;; we put the normal face properties on the invisible
944 ;; portion too, since emacs sometimes will position
945 ;; the cursor on an intangible character
946 (add-text-properties (match-beginning 0)
947 (match-beginning 2) invis-props)
948 (add-text-properties (match-beginning 2) (match-end 2) props)
949 (add-text-properties (match-end 2) (match-end 0) invis-props)
950 ;; in case specials were escaped, cause the unescaped
951 ;; text to be displayed
952 (unless (string= desc unesc-desc)
953 (add-text-properties (match-beginning 2) (match-end 2)
954 (list 'display desc))))
955 (add-text-properties (match-beginning 0)
956 (match-beginning 1) invis-props)
957 (add-text-properties (match-beginning 1) (match-end 0) props)
958 (add-text-properties (match-end 1) (match-end 0) invis-props)
959 (unless (string= link unesc-link)
960 (add-text-properties (match-beginning 1) (match-end 1)
961 (list 'display link))))
962 (goto-char (match-end 0))
963 (add-text-properties
964 (match-beginning 0) (match-end 0)
965 (muse-link-properties (muse-match-string-no-properties 0)
966 (muse-link-face link t)))))))
968 (defun muse-colors-implicit-link ()
969 "Color implicit links."
970 (unless (or (eq (get-text-property (match-beginning 0) 'invisible) 'muse)
971 (get-text-property (match-beginning 0) 'muse-comment)
972 (get-text-property (match-beginning 0) 'muse-directive)
973 (get-text-property (match-beginning 0) 'muse-no-implicit-link)
974 (eq (char-before (match-beginning 0)) ?\")
975 (eq (char-after (match-end 0)) ?\"))
976 ;; remove flyspell overlays
977 (when (fboundp 'flyspell-unhighlight-at)
978 (let ((cur (match-beginning 0)))
979 (while (> (match-end 0) cur)
980 (flyspell-unhighlight-at cur)
981 (setq cur (1+ cur)))))
982 ;; colorize link
983 (let ((link (muse-match-string-no-properties 0))
984 (face (muse-link-face (match-string 0))))
985 (when face
986 (add-text-properties (match-beginning 0) (match-end 0)
987 (muse-link-properties
988 (muse-match-string-no-properties 0) face))))))
990 (defun muse-colors-title ()
991 "Color #title directives."
992 (let ((beg (+ 7 (match-beginning 0))))
993 (add-text-properties beg (muse-line-end-position) '(muse-directive t))
994 ;; colorize <lisp> tags in #title after other <lisp> tags have had a
995 ;; chance to run, so that we can have behavior that is consistent
996 ;; with how the document is published
997 (setq muse-colors-delayed-commands
998 (cons (list 'muse-colors-title-lisp beg (muse-line-end-position))
999 muse-colors-delayed-commands))))
1001 (defun muse-colors-title-lisp (beg end)
1002 "Called after other highlighting is done for a region in order to handle
1003 <lisp> tags that exist in #title directives."
1004 (save-restriction
1005 (narrow-to-region beg end)
1006 (goto-char (point-min))
1007 (let ((muse-colors-inhibit-tags-in-directives nil)
1008 (muse-colors-tags '(("lisp" t t nil muse-colors-lisp-tag))))
1009 (while (re-search-forward muse-tag-regexp nil t)
1010 (muse-colors-custom-tags))))
1011 (add-text-properties beg end '(face muse-header-1)))
1013 (defun muse-colors-comment ()
1014 "Color comments."
1015 (add-text-properties (match-beginning 0) (muse-line-end-position)
1016 (list 'face 'font-lock-comment-face
1017 'muse-comment t)))
1020 (provide 'muse-colors)
1022 ;;; muse-colors.el ends here