lisp/muse-colors.el

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