lisp/muse-colors.el

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