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       ;; put in the proper group and give documentation
 142       (if later
 143           (unless (featurep 'xemacs)
 144             (muse-copy-face 'variable-pitch newsym)
 145             (set-face-attribute newsym nil :height (1+ (* 0.1 (- 5 num)))
 146                                 :weight 'bold))
 147         (if (featurep 'xemacs)
 148             (eval `(defface ,newsym
 149                      '((t (:size
 150                            ,(nth (1- num) '("24pt" "18pt" "14pt" "12pt" "11pt"))
 151                            :bold t)))
 152                      "Muse header face"
 153                      :group 'muse-colors))
 154           (eval `(defface ,newsym
 155                    '((t (:height ,(1+ (* 0.1 (- 5 num)))
 156                                  :inherit variable-pitch
 157                                  :weight bold)))
 158                    "Muse header face"
 159                    :group 'muse-colors)))))))
 160
 161 (progn (muse-make-faces-default))
 162
 163 (defun muse-make-faces (&optional frame)
 164   "Generate face definitions for headers based the user's preferences."
 165   (cond
 166    ((not muse-colors-autogen-headings)
 167     nil)
 168    ((eq muse-colors-autogen-headings t)
 169     (muse-make-faces-default t))
 170    (t
 171     (dolist (num '(1 2 3 4 5))
 172       (let ((newsym (intern (concat "muse-header-" (int-to-string num)))))
 173         ;; copy the desired face definition
 174         (muse-copy-face (nth (1- num) muse-colors-outline-faces-list)
 175                         newsym))))))
 176
 177 ;; after displaying the Emacs splash screen, the faces are wiped out,
 178 ;; so recover from that
 179 (add-hook 'window-setup-hook #'muse-make-faces)
 180 ;; ditto for when a new frame is created
 181 (when (boundp 'after-make-frame-functions)
 182   (add-hook 'after-make-frame-functions #'muse-make-faces))
 183
 184 (defface muse-link
 185   '((((class color) (background light))
 186      (:foreground "blue" :underline "blue" :bold t))
 187     (((class color) (background dark))
 188      (:foreground "cyan" :underline "cyan" :bold t))
 189     (t (:bold t)))
 190   "Face for Muse cross-references."
 191   :group 'muse-colors)
 192
 193 (defface muse-bad-link
 194   '((((class color) (background light))
 195      (:foreground "red" :underline "red" :bold t))
 196     (((class color) (background dark))
 197      (:foreground "coral" :underline "coral" :bold t))
 198     (t (:bold t)))
 199   "Face for bad Muse cross-references."
 200   :group 'muse-colors)
 201
 202 (defface muse-verbatim
 203   '((((class color) (background light))
 204      (:foreground "slate gray"))
 205     (((class color) (background dark))
 206      (:foreground "gray")))
 207   "Face for verbatim text."
 208   :group 'muse-colors)
 209
 210 (defface muse-emphasis-1
 211   '((t (:italic t)))
 212   "Face for italic emphasized text."
 213   :group 'muse-colors)
 214
 215 (defface muse-emphasis-2
 216   '((t (:bold t)))
 217   "Face for bold emphasized text."
 218   :group 'muse-colors)
 219
 220 (defface muse-emphasis-3
 221   '((t (:bold t :italic t)))
 222   "Face for bold italic emphasized text."
 223   :group 'muse-colors)
 224
 225 (muse-copy-face 'italic 'muse-emphasis-1)
 226 (muse-copy-face 'bold 'muse-emphasis-2)
 227 (muse-copy-face 'bold-italic 'muse-emphasis-3)
 228
 229 (defcustom muse-colors-buffer-hook nil
 230   "A hook run after a region is highlighted.
 231 Each function receives three arguments: BEG END VERBOSE.
 232 BEG and END mark the range being highlighted, and VERBOSE specifies
 233 whether progress messages should be displayed to the user."
 234   :type 'hook
 235   :group 'muse-colors)
 236
 237 (defvar muse-colors-regexp nil
 238   "Regexp matching each car of `muse-colors-markup'.")
 239 (defvar muse-colors-vector nil
 240   "Vector of all characters that are part of Muse markup.
 241 This is composed of the 2nd element of each `muse-colors-markup'
 242 entry.")
 243
 244 (defun muse-configure-highlighting (sym val)
 245   "Extract color markup information from VAL and set to SYM.
 246 This is usually called with `muse-colors-markup' as both arguments."
 247   (let ((regexps nil)
 248         (rules nil))
 249     (dolist (rule val)
 250       (let ((value (cond ((symbolp (car rule))
 251                           (symbol-value (car rule)))
 252                          ((stringp (car rule))
 253                           (car rule))
 254                          (t nil))))
 255         (when value
 256           (setq rules (cons rule rules))
 257           (setq regexps (cons value regexps)))))
 258     (setq rules (nreverse rules)
 259           regexps (nreverse regexps))
 260     (setq muse-colors-regexp (concat "\\("
 261                                      (mapconcat #'identity regexps "\\|")
 262                                      "\\)")
 263           muse-colors-vector (make-vector 128 nil))
 264     (while rules
 265       (if (eq (cadr (car rules)) t)
 266           (let ((i 0) (l 128))
 267             (while (< i l)
 268               (unless (aref muse-colors-vector i)
 269                 (aset muse-colors-vector i (nth 2 (car rules))))
 270               (setq i (1+ i))))
 271         (aset muse-colors-vector (cadr (car rules))
 272               (nth 2 (car rules))))
 273       (setq rules (cdr rules))))
 274   (set sym val))
 275
 276 (defun muse-colors-emphasized ()
 277   "Color emphasized text and headings."
 278   ;; Here we need to check four different points - the start and end
 279   ;; of the leading *s, and the start and end of the trailing *s.  We
 280   ;; allow the outsides to be surrounded by whitespace or punctuation,
 281   ;; but no word characters, and the insides must not be surrounded by
 282   ;; whitespace or punctuation.  Thus the following are valid:
 283   ;;
 284   ;; " *foo bar* "
 285   ;; "**foo**,"
 286   ;; and the following is invalid:
 287   ;; "** testing **"
 288   (let* ((beg (match-beginning 0))
 289          (e1 (match-end 0))
 290          (leader (- e1 beg))
 291          b2 e2 multiline)
 292     (unless (or (eq (get-text-property beg 'invisible) 'muse)
 293                 (get-text-property beg 'muse-comment)
 294                 (get-text-property beg 'muse-directive))
 295       ;; check if it's a header
 296       (if (eq (char-after e1) ?\ )
 297           (when (or (= beg (point-min))
 298                     (eq (char-before beg) ?\n))
 299             (add-text-properties
 300              (muse-line-beginning-position) (muse-line-end-position)
 301              (list 'face (intern (concat "muse-header-"
 302                                          (int-to-string leader))))))
 303         ;; beginning of line or space or symbol
 304         (when (or (= beg (point-min))
 305                   (eq (char-syntax (char-before beg)) ?\ )
 306                   (memq (char-before beg)
 307                         '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
 308           (save-excursion
 309             (skip-chars-forward "^*<>\n" muse-colors-region-end)
 310             (when (eq (char-after) ?\n)
 311               (setq multiline t)
 312               (skip-chars-forward "^*<>" muse-colors-region-end))
 313             (setq b2 (point))
 314             (skip-chars-forward "*" muse-colors-region-end)
 315             (setq e2 (point))
 316             ;; Abort if space exists just before end
 317             ;; or bad leader
 318             ;; or no '*' at end
 319             ;; or word constituent follows
 320             (unless (or (> leader 5)
 321                         (not (eq leader (- e2 b2)))
 322                         (eq (char-syntax (char-before b2)) ?\ )
 323                         (not (eq (char-after b2) ?*))
 324                         (and (not (eobp))
 325                              (eq (char-syntax (char-after (1+ b2))) ?w)))
 326               (add-text-properties beg e1 '(invisible muse))
 327               (add-text-properties
 328                e1 b2 (list 'face (cond ((= leader 1) 'muse-emphasis-1)
 329                                        ((= leader 2) 'muse-emphasis-2)
 330                                        ((= leader 3) 'muse-emphasis-3))))
 331               (add-text-properties b2 e2 '(invisible muse))
 332               (when multiline
 333                 (add-text-properties
 334                  beg e2 '(font-lock-multiline t))))))))))
 335
 336 (defun muse-colors-underlined ()
 337   "Color underlined text."
 338   (let ((start (match-beginning 0))
 339         multiline)
 340     (unless (or (eq (get-text-property start 'invisible) 'muse)
 341                 (get-text-property start 'muse-comment)
 342                 (get-text-property start 'muse-directive))
 343       ;; beginning of line or space or symbol
 344       (when (or (= start (point-min))
 345                 (eq (char-syntax (char-before start)) ?\ )
 346                 (memq (char-before start)
 347                       '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
 348         (save-excursion
 349           (skip-chars-forward "^_<>\n" muse-colors-region-end)
 350           (when (eq (char-after) ?\n)
 351             (setq multiline t)
 352             (skip-chars-forward "^_<>" muse-colors-region-end))
 353           ;; Abort if space exists just before end
 354           ;; or no '_' at end
 355           ;; or word constituent follows
 356           (unless (or (eq (char-syntax (char-before (point))) ?\ )
 357                       (not (eq (char-after (point)) ?_))
 358                       (and (not (eobp))
 359                            (eq (char-syntax (char-after (1+ (point)))) ?w)))
 360             (add-text-properties start (1+ start) '(invisible muse))
 361             (add-text-properties (1+ start) (point) '(face underline))
 362             (add-text-properties (point)
 363                                  (min (1+ (point)) (point-max))
 364                                  '(invisible muse))
 365             (when multiline
 366               (add-text-properties
 367                start (min (1+ (point)) (point-max))
 368                '(font-lock-multiline t)))))))))
 369
 370 (defun muse-colors-verbatim ()
 371   "Render in teletype and suppress further parsing."
 372   (let ((start (match-beginning 0))
 373         multiline)
 374     (unless (or (eq (get-text-property start 'invisible) 'muse)
 375                 (get-text-property start 'muse-comment)
 376                 (get-text-property start 'muse-directive))
 377       ;; beginning of line or space or symbol
 378       (when (or (= start (point-min))
 379                 (eq (char-syntax (char-before start)) ?\ )
 380                 (memq (char-before start)
 381                       '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
 382         (let ((pos (point)))
 383           (skip-chars-forward "^=\n" muse-colors-region-end)
 384           (when (eq (char-after) ?\n)
 385             (setq multiline t)
 386             (skip-chars-forward "^=" muse-colors-region-end))
 387           ;; Abort if space exists just before end
 388           ;; or no '=' at end
 389           ;; or word constituent follows
 390           (unless (or (eq (char-syntax (char-before (point))) ?\ )
 391                       (not (eq (char-after (point)) ?=))
 392                       (and (not (eobp))
 393                            (eq (char-syntax (char-after (1+ (point)))) ?w)))
 394             (setq pos (min (1+ (point)) (point-max)))
 395             (add-text-properties start (1+ start) '(invisible muse))
 396             (add-text-properties (1+ start) (point) '(face muse-verbatim))
 397             (add-text-properties (point)
 398                                  (min (1+ (point)) (point-max))
 399                                  '(invisible muse))
 400             (when multiline
 401               (add-text-properties
 402                start (min (1+ (point)) (point-max))
 403                '(font-lock-multiline t))))
 404           (goto-char pos))))))
 405
 406 (defcustom muse-colors-markup
 407   `(;; make emphasized text appear emphasized
 408     ("\\*\\{1,5\\}" ?* muse-colors-emphasized)
 409
 410     ;; make underlined text appear underlined
 411     (,(concat "_[^" muse-regexp-blank "_\n]")
 412      ?_ muse-colors-underlined)
 413
 414     ("^#title " ?\# muse-colors-title)
 415
 416     (muse-explicit-link-regexp ?\[ muse-colors-explicit-link)
 417
 418     ;; render in teletype and suppress further parsing
 419     (,(concat "=[^" muse-regexp-blank "=\n]") ?= muse-colors-verbatim)
 420
 421     ;; highlight any markup tags encountered
 422     (muse-tag-regexp ?\< muse-colors-custom-tags)
 423
 424     ;; display comments
 425     (,(concat "^;[" muse-regexp-blank "]") ?\; muse-colors-comment)
 426
 427     ;; this has to come later since it doesn't have a special
 428     ;; character in the second cell
 429     (muse-url-regexp t muse-colors-implicit-link)
 430     )
 431   "Expressions to highlight an Emacs Muse buffer.
 432 These are arranged in a rather special fashion, so as to be as quick as
 433 possible.
 434
 435 Each element of the list is itself a list, of the form:
 436
 437   (LOCATE-REGEXP TEST-CHAR MATCH-FUNCTION)
 438
 439 LOCATE-REGEXP is a partial regexp, and should be the smallest possible
 440 regexp to differentiate this rule from other rules.  It may also be a
 441 symbol containing such a regexp.  The buffer region is scanned only
 442 once, and LOCATE-REGEXP indicates where the scanner should stop to
 443 look for highlighting possibilities.
 444
 445 TEST-CHAR is a char or t.  The character should match the beginning
 446 text matched by LOCATE-REGEXP.  These chars are used to build a vector
 447 for fast MATCH-FUNCTION calling.
 448
 449 MATCH-FUNCTION is the function called when a region has been
 450 identified.  It is responsible for adding the appropriate text
 451 properties to change the appearance of the buffer.
 452
 453 This markup is used to modify the appearance of the original text to
 454 make it look more like the published HTML would look (like making some
 455 markup text invisible, inlining images, etc).
 456
 457 font-lock is used to apply the markup rules, so that they can happen
 458 on a deferred basis.  They are not always accurate, but you can use
 459 \\[font-lock-fontifty-block] near the point of error to force
 460 fontification in that area."
 461   :type '(repeat
 462           (list :tag "Highlight rule"
 463                 (choice (regexp :tag "Locate regexp")
 464                         (symbol :tag "Regexp symbol"))
 465                 (choice (character :tag "Confirm character")
 466                         (const :tag "Default rule" t))
 467                 function))
 468   :set 'muse-configure-highlighting
 469   :group 'muse-colors)
 470
 471 ;; XEmacs users don't have `font-lock-multiline'.
 472 (unless (boundp 'font-lock-multiline)
 473   (defvar font-lock-multiline nil))
 474
 475 (defun muse-use-font-lock ()
 476   "Set up font-locking for Muse."
 477   (muse-add-to-invisibility-spec 'muse)
 478   (set (make-local-variable 'font-lock-multiline) 'undecided)
 479   (set (make-local-variable 'font-lock-defaults)
 480        `(nil t nil nil beginning-of-line
 481          (font-lock-fontify-region-function . muse-colors-region)
 482          (font-lock-unfontify-region-function
 483           . muse-unhighlight-region)))
 484   (set (make-local-variable 'font-lock-fontify-region-function)
 485        'muse-colors-region)
 486   (set (make-local-variable 'font-lock-unfontify-region-function)
 487        'muse-unhighlight-region)
 488   (muse-make-faces)
 489   (muse-configure-highlighting 'muse-colors-markup muse-colors-markup)
 490   (font-lock-mode t))
 491
 492 (defun muse-colors-buffer ()
 493   "Re-highlight the entire Muse buffer."
 494   (interactive)
 495   (muse-colors-region (point-min) (point-max) t))
 496
 497 (defvar muse-colors-fontifying-p nil
 498   "Indicate whether Muse is fontifying the current buffer.")
 499 (make-variable-buffer-local 'muse-colors-fontifying-p)
 500
 501 (defvar muse-colors-delayed-commands nil
 502   "Commands to be run immediately after highlighting a region.
 503
 504 This is meant to accommodate highlighting <lisp> in #title
 505 directives after everything else.
 506
 507 It may be modified by Muse functions during highlighting, but not
 508 the user.")
 509 (make-variable-buffer-local 'muse-colors-delayed-commands)
 510
 511 (defun muse-colors-region (beg end &optional verbose)
 512   "Apply highlighting according to `muse-colors-markup'.
 513 Note that this function should NOT change the buffer, nor should any
 514 of the functions listed in `muse-colors-markup'."
 515   (let ((buffer-undo-list t)
 516         (inhibit-read-only t)
 517         (inhibit-point-motion-hooks t)
 518         (inhibit-modification-hooks t)
 519         (modified-p (buffer-modified-p))
 520         (muse-colors-fontifying-p t)
 521         (muse-colors-region-end (muse-line-end-position end))
 522         (muse-colors-delayed-commands nil)
 523         deactivate-mark)
 524     (unwind-protect
 525         (save-excursion
 526           (save-restriction
 527             (widen)
 528             ;; check to see if we should expand the beg/end area for
 529             ;; proper multiline matches
 530             (when (and font-lock-multiline
 531                        (> beg (point-min))
 532                        (get-text-property (1- beg) 'font-lock-multiline))
 533               ;; We are just after or in a multiline match.
 534               (setq beg (or (previous-single-property-change
 535                              beg 'font-lock-multiline)
 536                             (point-min)))
 537               (goto-char beg)
 538               (setq beg (muse-line-beginning-position)))
 539             (when font-lock-multiline
 540               (setq end (or (text-property-any end (point-max)
 541                                                'font-lock-multiline nil)
 542                             (point-max))))
 543             (goto-char end)
 544             (setq end (muse-line-beginning-position 2))
 545             ;; Undo any fontification in the area.
 546             (font-lock-unfontify-region beg end)
 547             ;; And apply fontification based on `muse-colors-markup'
 548             (let ((len (float (- end beg)))
 549                   (case-fold-search nil)
 550                   markup-func)
 551               (goto-char beg)
 552               (while (and (< (point) end)
 553                           (re-search-forward muse-colors-regexp end t))
 554                 (if verbose
 555                     (message "Highlighting buffer...%d%%"
 556                              (* (/ (float (- (point) beg)) len) 100)))
 557                 (setq markup-func
 558                       (aref muse-colors-vector
 559                             (char-after (match-beginning 0))))
 560                 (when markup-func (funcall markup-func)))
 561               (dolist (command muse-colors-delayed-commands)
 562                 (apply (car command) (cdr command)))
 563               (run-hook-with-args 'muse-colors-buffer-hook
 564                                   beg end verbose)
 565               (if verbose (message "Highlighting buffer...done")))))
 566       (set-buffer-modified-p modified-p))))
 567
 568 (defcustom muse-colors-tags
 569   '(("example"  t nil nil muse-colors-example-tag)
 570     ("code"     t nil nil muse-colors-example-tag)
 571     ("verbatim" t nil nil muse-colors-literal-tag)
 572     ("lisp"     t t   nil muse-colors-lisp-tag)
 573     ("literal"  t nil nil muse-colors-literal-tag))
 574   "A list of tag specifications for specially highlighting text.
 575 XML-style tags are the best way to add custom highlighting to Muse.
 576 This is easily accomplished by customizing this list of markup tags.
 577
 578 For each entry, the name of the tag is given, whether it expects
 579 a closing tag and/or an optional set of attributes, whether it is
 580 nestable, and a function that performs whatever action is desired
 581 within the delimited region.
 582
 583 The function is called with three arguments, the beginning and
 584 end of the region surrounded by the tags. If properties are
 585 allowed, they are passed as a third argument in the form of an
 586 alist. The `end' argument to the function is the last character
 587 of the enclosed tag or region.
 588
 589 Functions should not modify the contents of the buffer."
 590   :type '(repeat (list (string :tag "Markup tag")
 591                        (boolean :tag "Expect closing tag" :value t)
 592                        (boolean :tag "Parse attributes" :value nil)
 593                        (boolean :tag "Nestable" :value nil)
 594                        function))
 595   :group 'muse-colors)
 596
 597 (defvar muse-colors-inhibit-tags-in-directives t
 598   "If non-nil, don't allow tags to be interpreted in directives.
 599 This is used to delay highlighting of <lisp> tags in #title until later.")
 600 (make-variable-buffer-local 'muse-colors-inhibit-tags-in-directives)
 601
 602 (defsubst muse-colors-tag-info (tagname &rest args)
 603   "Get tag info associated with TAGNAME, ignoring ARGS."
 604   (assoc tagname muse-colors-tags))
 605
 606 (defun muse-colors-custom-tags ()
 607   "Highlight `muse-colors-tags'."
 608   (save-excursion
 609     (goto-char (match-beginning 0))
 610     (looking-at muse-tag-regexp))
 611   (let ((tag-info (muse-colors-tag-info (match-string 1))))
 612     (unless (or (not tag-info)
 613                 (get-text-property (match-beginning 0) 'muse-comment)
 614                 (and muse-colors-inhibit-tags-in-directives
 615                      (get-text-property (match-beginning 0) 'muse-directive)))
 616       (let ((closed-tag (match-string 3))
 617             (start (match-beginning 0))
 618             end attrs)
 619         (when (nth 2 tag-info)
 620           (let ((attrstr (match-string 2)))
 621             (while (and attrstr
 622                         (string-match (concat "\\([^"
 623                                               muse-regexp-blank
 624                                               "=\n]+\\)\\(=\""
 625                                               "\\([^\"]+\\)\"\\)?")
 626                                       attrstr))
 627               (let ((attr (cons (downcase
 628                                  (muse-match-string-no-properties 1 attrstr))
 629                                 (muse-match-string-no-properties 3 attrstr))))
 630                 (setq attrstr (replace-match "" t t attrstr))
 631                 (if attrs
 632                     (nconc attrs (list attr))
 633                   (setq attrs (list attr)))))))
 634         (if (and (cadr tag-info) (not closed-tag))
 635             (if (muse-goto-tag-end (car tag-info) (nth 3 tag-info))
 636                 (setq end (match-end 0))
 637               (setq tag-info nil)))
 638         (when tag-info
 639           (let ((args (list start end)))
 640             (if (nth 2 tag-info)
 641                 (nconc args (list attrs)))
 642             (apply (nth 4 tag-info) args)))))))
 643
 644 (defun muse-unhighlight-region (begin end &optional verbose)
 645   "Remove all visual highlights in the buffer (except font-lock)."
 646   (let ((buffer-undo-list t)
 647         (inhibit-read-only t)
 648         (inhibit-point-motion-hooks t)
 649         (inhibit-modification-hooks t)
 650         (modified-p (buffer-modified-p))
 651         deactivate-mark)
 652     (unwind-protect
 653         (remove-text-properties
 654          begin end '(face nil font-lock-multiline nil end-glyph nil
 655                           invisible nil intangible nil display nil
 656                           mouse-face nil keymap nil help-echo nil
 657                           muse-link nil muse-directive nil muse-comment nil
 658                           muse-no-implicit-link nil))
 659       (set-buffer-modified-p modified-p))))
 660
 661 (defun muse-colors-example-tag (beg end)
 662   "Strip properties and colorize with `muse-verbatim'."
 663   (muse-unhighlight-region beg end)
 664   (let ((multi (save-excursion
 665                  (goto-char beg)
 666                  (forward-line 1)
 667                  (> end (point)))))
 668     (add-text-properties beg end `(face muse-verbatim
 669                                    font-lock-multiline ,multi))))
 670
 671 (defun muse-colors-literal-tag (beg end)
 672   "Strip properties and mark as literal."
 673   (muse-unhighlight-region beg end)
 674   (let ((multi (save-excursion
 675                  (goto-char beg)
 676                  (forward-line 1)
 677                  (> end (point)))))
 678     (add-text-properties beg end `(font-lock-multiline ,multi))))
 679
 680 (defun muse-colors-lisp-tag (beg end attrs)
 681   "Color the region enclosed by a <lisp> tag."
 682   (if (not muse-colors-evaluate-lisp-tags)
 683       (muse-colors-literal-tag beg end)
 684     (muse-unhighlight-region beg end)
 685     (let (beg-lisp end-lisp)
 686       (save-match-data
 687         (goto-char beg)
 688         (setq beg-lisp (and (looking-at "<[^>]+>")
 689                             (match-end 0)))
 690         (goto-char end)
 691         (setq end-lisp (and (muse-looking-back "</[^>]+>")
 692                             (match-beginning 0))))
 693       (add-text-properties
 694        beg end
 695        (list 'font-lock-multiline t
 696              'display (muse-eval-lisp
 697                        (concat
 698                         "(progn "
 699                         (buffer-substring-no-properties beg-lisp end-lisp)
 700                         ")"))
 701              'intangible t)))))
 702
 703 (defvar muse-mode-local-map
 704   (let ((map (make-sparse-keymap)))
 705     (define-key map [return] 'muse-follow-name-at-point)
 706     (define-key map [(control ?m)] 'muse-follow-name-at-point)
 707     (define-key map [(shift return)] 'muse-follow-name-at-point-other-window)
 708     (if (featurep 'xemacs)
 709         (progn
 710           (define-key map [(button2)] 'muse-follow-name-at-mouse)
 711           (define-key map [(shift button2)]
 712             'muse-follow-name-at-mouse-other-window))
 713       (define-key map [(shift control ?m)]
 714         'muse-follow-name-at-point-other-window)
 715       (define-key map [mouse-2] 'muse-follow-name-at-mouse)
 716       (define-key map [(shift mouse-2)]
 717         'muse-follow-name-at-mouse-other-window)
 718       (unless (eq emacs-major-version 21)
 719         (set-keymap-parent map muse-mode-map)))
 720     map)
 721   "Local keymap used by Muse while on a link.")
 722
 723 (defvar muse-keymap-property
 724   (if (or (featurep 'xemacs)
 725           (>= emacs-major-version 21))
 726       'keymap
 727     'local-map)
 728   "The name of the keymap or local-map property.")
 729
 730 (defsubst muse-link-properties (help-str &optional face)
 731   "Determine text properties to use for a link."
 732   (append (if face
 733               (list 'face face 'mouse-face 'highlight 'muse-link t)
 734             (list 'invisible 'muse 'intangible t))
 735           (list 'help-echo help-str 'rear-nonsticky t
 736                 muse-keymap-property muse-mode-local-map)))
 737
 738 (defun muse-link-face (link-name &optional explicit)
 739   "Return the type of LINK-NAME as a face symbol.
 740 For EXPLICIT links, this is either a normal link or a bad-link
 741 face.  For implicit links, it is either colored normally or
 742 ignored."
 743   (save-match-data
 744     (let ((link (if explicit
 745                     (muse-handle-explicit-link link-name)
 746                   (muse-handle-implicit-link link-name))))
 747       (when link
 748         (cond ((string-match muse-url-regexp link)
 749                'muse-link)
 750               ((muse-file-remote-p link)
 751                'muse-link)
 752               ((string-match muse-file-regexp link)
 753                (when (string-match "/[^/]+#[^#./]+\\'" link)
 754                  ;; strip anchor from the end of a path
 755                  (setq link (substring link 0 (match-beginning 0))))
 756                (if (file-exists-p link)
 757                    'muse-link
 758                  'muse-bad-link))
 759               ((not (featurep 'muse-project))
 760                'muse-link)
 761               (t
 762                (if (string-match "#" link)
 763                    (setq link (substring link 0 (match-beginning 0))))
 764                (if (or (and (muse-project-of-file)
 765                             (muse-project-page-file
 766                              link muse-current-project t))
 767                        (file-exists-p link))
 768                    'muse-link
 769                  'muse-bad-link)))))))
 770
 771 (defun muse-colors-use-publishing-directory (link)
 772   "Make LINK relative to the directory where we will publish the
 773 current file."
 774   (let ((style (car (muse-project-applicable-styles
 775                      link (cddr (muse-project)))))
 776         path)
 777     (when (and style
 778                (setq path (muse-style-element :path style)))
 779       (expand-file-name link path))))
 780
 781 (defun muse-colors-resolve-image-file (link)
 782   "Determine if we can create images and see if the link is an image
 783 file."
 784   (save-match-data
 785     (and (or (fboundp 'create-image)
 786              (fboundp 'make-glyph))
 787          (not (string-match "\\`[uU][rR][lL]:" link))
 788          (string-match muse-image-regexp link))))
 789
 790 (defun muse-make-file-glyph (filename)
 791   "Given a file name, return a newly-created image glyph.
 792 This is a hack for supporting inline images in XEmacs."
 793   (let ((case-fold-search nil))
 794     ;; Scan filename to determine image type
 795     (when (fboundp 'make-glyph)
 796       (save-match-data
 797         (cond ((string-match "jpe?g" filename)
 798                (make-glyph (vector 'jpeg :file filename) 'buffer))
 799               ((string-match "gif" filename)
 800                (make-glyph (vector 'gif :file filename) 'buffer))
 801               ((string-match "png" filename)
 802                (make-glyph (vector 'png :file filename) 'buffer)))))))
 803
 804 (defun muse-colors-insert-image (link beg end invis-props)
 805   "Create an image using create-image or make-glyph and insert it
 806 in place of an image link defined by BEG and END."
 807   (setq link (expand-file-name link))
 808   (let ((image-file (cond
 809                      ((eq muse-colors-inline-image-method 'default-directory)
 810                       link)
 811                      ((functionp muse-colors-inline-image-method)
 812                       (funcall muse-colors-inline-image-method link))))
 813         glyph)
 814     (when (stringp image-file)
 815       (if (fboundp 'create-image)
 816           ;; use create-image and display property
 817           (let ((display-stuff (condition-case nil
 818                                    (create-image image-file)
 819                                  (error nil))))
 820             (when display-stuff
 821               (add-text-properties beg end (list 'display display-stuff))))
 822         ;; use make-glyph and invisible property
 823         (and (setq glyph (muse-make-file-glyph image-file))
 824              (progn
 825                (add-text-properties beg end invis-props)
 826                (add-text-properties beg end (list
 827                                              'end-glyph glyph
 828                                              'help-echo link))))))))
 829
 830 (defun muse-colors-explicit-link ()
 831   "Color explicit links."
 832   (when (and (eq ?\[ (char-after (match-beginning 0)))
 833              (not (get-text-property (match-beginning 0) 'muse-comment))
 834              (not (get-text-property (match-beginning 0) 'muse-directive)))
 835     ;; remove flyspell overlays
 836     (when (fboundp 'flyspell-unhighlight-at)
 837       (let ((cur (match-beginning 0)))
 838         (while (> (match-end 0) cur)
 839           (flyspell-unhighlight-at cur)
 840           (setq cur (1+ cur)))))
 841     (save-excursion
 842       (goto-char (match-beginning 0))
 843       (looking-at muse-explicit-link-regexp))
 844     (let* ((unesc-link (muse-get-link))
 845            (unesc-desc (muse-get-link-desc))
 846            (link (muse-link-unescape unesc-link))
 847            (desc (muse-link-unescape unesc-desc))
 848            (props (muse-link-properties desc (muse-link-face link t)))
 849            (invis-props (append props (muse-link-properties desc))))
 850       ;; see if we should try and inline an image
 851       (if (and muse-colors-inline-images
 852                (or (muse-colors-resolve-image-file link)
 853                    (and desc
 854                         (muse-colors-resolve-image-file desc)
 855                         (setq link desc))))
 856           ;; we found an image, so inline it
 857           (muse-colors-insert-image
 858            link
 859            (match-beginning 0) (match-end 0) invis-props)
 860         (if desc
 861             (progn
 862               ;; we put the normal face properties on the invisible
 863               ;; portion too, since emacs sometimes will position
 864               ;; the cursor on an intangible character
 865               (add-text-properties (match-beginning 0)
 866                                    (match-beginning 2) invis-props)
 867               (add-text-properties (match-beginning 2) (match-end 2) props)
 868               (add-text-properties (match-end 2) (match-end 0) invis-props)
 869               ;; in case specials were escaped, cause the unescaped
 870               ;; text to be displayed
 871               (unless (string= desc unesc-desc)
 872                 (add-text-properties (match-beginning 2) (match-end 2)
 873                                      (list 'display desc))))
 874           (add-text-properties (match-beginning 0)
 875                                (match-beginning 1) invis-props)
 876           (add-text-properties (match-beginning 1) (match-end 0) props)
 877           (add-text-properties (match-end 1) (match-end 0) invis-props)
 878           (unless (string= link unesc-link)
 879             (add-text-properties (match-beginning 1) (match-end 1)
 880                                  (list 'display link))))
 881         (goto-char (match-end 0))
 882         (add-text-properties
 883          (match-beginning 0) (match-end 0)
 884          (muse-link-properties (muse-match-string-no-properties 0)
 885                                (muse-link-face link t)))))))
 886
 887 (defun muse-colors-implicit-link ()
 888   "Color implicit links."
 889   (unless (or (eq (get-text-property (match-beginning 0) 'invisible) 'muse)
 890               (get-text-property (match-beginning 0) 'muse-comment)
 891               (get-text-property (match-beginning 0) 'muse-directive)
 892               (get-text-property (match-beginning 0) 'muse-no-implicit-link)
 893               (eq (char-before (match-beginning 0)) ?\")
 894               (eq (char-after (match-end 0)) ?\"))
 895     ;; remove flyspell overlays
 896     (when (fboundp 'flyspell-unhighlight-at)
 897       (let ((cur (match-beginning 0)))
 898         (while (> (match-end 0) cur)
 899           (flyspell-unhighlight-at cur)
 900           (setq cur (1+ cur)))))
 901     ;; colorize link
 902     (let ((link (muse-match-string-no-properties 1))
 903           (face (muse-link-face (match-string 1))))
 904       (when face
 905         (add-text-properties (match-beginning 1) (match-end 0)
 906                              (muse-link-properties
 907                               (muse-match-string-no-properties 1) face))))))
 908
 909 (defun muse-colors-title ()
 910   "Color #title directives."
 911   (let ((beg (+ 7 (match-beginning 0))))
 912     (add-text-properties beg (muse-line-end-position) '(muse-directive t))
 913     ;; colorize <lisp> tags in #title after other <lisp> tags have had a
 914     ;; chance to run, so that we can have behavior that is consistent
 915     ;; with how the document is published
 916     (setq muse-colors-delayed-commands
 917           (cons (list 'muse-colors-title-lisp beg (muse-line-end-position))
 918                 muse-colors-delayed-commands))))
 919
 920 (defun muse-colors-title-lisp (beg end)
 921   "Called after other highlighting is done for a region in order to handle
 922 <lisp> tags that exist in #title directives."
 923   (save-restriction
 924     (narrow-to-region beg end)
 925     (goto-char (point-min))
 926     (let ((muse-colors-inhibit-tags-in-directives nil)
 927           (muse-colors-tags '(("lisp" t t nil muse-colors-lisp-tag))))
 928       (while (re-search-forward muse-tag-regexp nil t)
 929         (muse-colors-custom-tags))))
 930   (add-text-properties beg end '(face muse-header-1)))
 931
 932 (defun muse-colors-comment ()
 933   "Color comments."
 934   (add-text-properties (match-beginning 0) (muse-line-end-position)
 935                        (list 'face 'font-lock-comment-face
 936                              'muse-comment t)))
 937
 938
 939 (provide 'muse-colors)
 940
 941 ;;; muse-colors.el ends here