muse-colors.el

   1 ;;; muse-colors.el --- Coloring and highlighting used by Muse
   2
   3 ;; Copyright (C) 2004, 2005  Free Software Foundation, Inc.
   4
   5 ;; Emacs Lisp Archive Entry
   6 ;; Filename: muse-colors.el
   7 ;; Version: 3.00 ALPHA
   8 ;; Date: Thu 11-Mar-2004
   9 ;; Keywords: hypermedia
  10 ;; Author: John Wiegley (johnw AT gnu DOT org)
  11 ;; Maintainer: Michael Olson (mwolson AT gnu DOT org)
  12 ;; URL: http://www.mwolson.org/projects/MuseMode.html
  13 ;; Compatibility: Emacs21
  14
  15 ;; This file is not part of GNU Emacs.
  16
  17 ;; This is free software; you can redistribute it and/or modify it under
  18 ;; the terms of the GNU General Public License as published by the Free
  19 ;; Software Foundation; either version 2, or (at your option) any later
  20 ;; version.
  21 ;;
  22 ;; This is distributed in the hope that it will be useful, but WITHOUT
  23 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  24 ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  25 ;; for more details.
  26 ;;
  27 ;; You should have received a copy of the GNU General Public License
  28 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  29 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  30 ;; MA 02111-1307, USA.
  31
  32 ;;; Commentary:
  33
  34 ;;; Contributors:
  35
  36 ;; Lan Yufeng (nlany DOT web AT gmail DOT com) found an error where
  37 ;; headings were being given the wrong face, contributing a patch to
  38 ;; fix this.
  39
  40 ;;; Code:
  41
  42 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43 ;;
  44 ;; Emacs Muse Highlighting
  45 ;;
  46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  47
  48 (require 'muse-mode)
  49 (require 'muse-regexps)
  50 (require 'font-lock)
  51
  52 (defgroup muse-colors nil
  53   "Options controlling the behavior of Emacs Muse highlighting.
  54 See `muse-colors-buffer' for more information."
  55   :group 'muse-mode)
  56
  57 (defcustom muse-colors-autogen-headings t
  58   "Specify whether the heading faces should be auto-generated.
  59 The default is to scale them.
  60
  61 Choosing 'outline will copy the colors from the outline-mode
  62 headings.
  63
  64 If you want to customize each of the headings individually, set
  65 this to nil."
  66   :type '(choice (const :tag "Default (scaled) headings" t)
  67                  (const :tag "Use outline-mode headings" outline)
  68                  (const :tag "Don't touch the headings" nil))
  69   :group 'muse-colors)
  70
  71 (defvar muse-colors-outline-faces-list
  72   (if (facep 'outline-1)
  73       '(outline-1 outline-2 outline-3 outline-4)
  74     ;; These are supposed to be equivalent in coloring
  75     '(font-lock-function-name-face
  76       font-lock-variable-name-face
  77       font-lock-keyword-face
  78       font-lock-builtin-face))
  79   "Outline faces to use when assigning Muse header faces.")
  80
  81 (defun muse-make-faces ()
  82   (dolist (num '(1 2 3 4))
  83     (setq newsym (intern (concat "muse-header-"
  84                                  (int-to-string num))))
  85     (cond
  86      ((null muse-colors-autogen-headings)
  87       (make-empty-face newsym))
  88      ((featurep 'xemacs)
  89       (if (eq muse-colors-autogen-headings 'outline)
  90           (copy-face (nth (1- num)
  91                           muse-colors-outline-faces-list)
  92                      newsym)
  93         (eval `(defface ,newsym
  94                  '((t (:size
  95                        ,(nth (1- num) '("24pt" "18pt" "14pt" "12pt"))
  96                        :bold t)))
  97                  "Muse header face"
  98                  :group 'muse-colors))))
  99      ((< emacs-major-version 21)
 100       (if (eq muse-colors-autogen-headings 'outline)
 101           (copy-face (nth (1- num)
 102                           muse-colors-outline-faces-list)
 103                      newsym)
 104         (copy-face 'default newsym)))
 105      ((eq muse-colors-autogen-headings 'outline)
 106       (eval `(defface ,newsym
 107                '((t (:inherit
 108                      ,(nth (1- num)
 109                            muse-colors-outline-faces-list))))
 110                "Muse header face"
 111                :group 'muse-colors)))
 112      (t
 113       (eval `(defface ,newsym
 114                '((t (:height ,(1+ (* 0.1 (- 5 num)))
 115                              :inherit variable-pitch
 116                              :weight bold)))
 117                "Muse header face"
 118                :group 'muse-colors))))))
 119
 120 (defface muse-link-face
 121   '((((class color) (background light))
 122      (:foreground "green" :underline "green" :bold t))
 123     (((class color) (background dark))
 124      (:foreground "cyan" :underline "cyan" :bold t))
 125     (t (:bold t)))
 126   "Face for Muse cross-references."
 127   :group 'muse-colors)
 128
 129 (defface muse-bad-link-face
 130   '((((class color) (background light))
 131      (:foreground "red" :underline "red" :bold t))
 132     (((class color) (background dark))
 133      (:foreground "coral" :underline "coral" :bold t))
 134     (t (:bold t)))
 135   "Face for bad Muse cross-references."
 136   :group 'muse-colors)
 137
 138 (defcustom muse-colors-buffer-hook nil
 139   "A hook run after a region is highlighted.
 140 Each function receives three arguments: BEG END VERBOSE.
 141 BEG and END mark the range being highlighted, and VERBOSE specifies
 142 whether progress messages should be displayed to the user."
 143   :type 'hook
 144   :group 'muse-colors)
 145
 146 (defvar muse-colors-regexp nil)
 147 (defvar muse-colors-vector nil)
 148
 149 (defun muse-configure-highlighting (sym val)
 150   (setq muse-colors-regexp
 151         (concat "\\(" (mapconcat (function
 152                                   (lambda (rule)
 153                                     (if (symbolp (car rule))
 154                                         (symbol-value (car rule))
 155                                       (car rule)))) val "\\|") "\\)")
 156         muse-colors-vector (make-vector 128 nil))
 157   (let ((rules val))
 158     (while rules
 159       (if (eq (cadr (car rules)) t)
 160           (let ((i 0) (l 128))
 161             (while (< i l)
 162               (unless (aref muse-colors-vector i)
 163                 (aset muse-colors-vector i (nth 2 (car rules))))
 164               (setq i (1+ i))))
 165         (aset muse-colors-vector (cadr (car rules))
 166               (nth 2 (car rules))))
 167       (setq rules (cdr rules))))
 168   (set sym val))
 169
 170 (eval-when-compile
 171   (defvar end))
 172
 173 (defun muse-colors-emphasized ()
 174   ;; Here we need to check four different points - the start and end
 175   ;; of the leading *s, and the start and end of the trailing *s.  We
 176   ;; allow the outsides to be surrounded by whitespace or punctuation,
 177   ;; but no word characters, and the insides must not be surrounded by
 178   ;; whitespace or punctuation.  Thus the following are valid:
 179   ;;
 180   ;; " *foo bar* "
 181   ;; "**foo**,"
 182   ;; and the following is invalid:
 183   ;; "** testing **"
 184   (let* ((beg (match-beginning 0))
 185          (e1 (match-end 0))
 186          (leader (- e1 beg))
 187          b2 e2 multiline)
 188     (unless (get-text-property beg 'invisible)
 189       ;; check if it's a header
 190       (if (eq (char-after e1) ?\ )
 191           (when (or (= beg (point-min))
 192                     (eq (char-before beg) ?\n))
 193             (add-text-properties
 194              (line-beginning-position) (line-end-position)
 195              (list 'face (intern (concat "muse-header-"
 196                                          (int-to-string leader))))))
 197         ;; beginning of line or space or symbol
 198         (when (or (= beg (point-min))
 199                   (memq (char-syntax (char-before beg)) '(?\  ?\-))
 200                   (memq (char-before beg)
 201                         '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
 202           (save-excursion
 203             (skip-chars-forward "^*<>\n" end)
 204             (when (eq (char-after) ?\n)
 205               (setq multiline t)
 206               (skip-chars-forward "^*<>" end))
 207             (setq b2 (point))
 208             (skip-chars-forward "*" end)
 209             (setq e2 (point))
 210             ;; Abort if space exists just before end
 211             ;; or bad leader
 212             ;; or no '*' at end
 213             (unless (or (> leader 3)
 214                         (not (eq leader (- e2 b2)))
 215                         (eq (char-before b2) ?\ )
 216                         (not (eq (char-after b2) ?*)))
 217               (add-text-properties beg e1 '(invisible t))
 218               (add-text-properties
 219                e1 b2 (list 'face (cond ((= leader 1) 'italic)
 220                                        ((= leader 2) 'bold)
 221                                        ((= leader 3) 'bold-italic))))
 222               (add-text-properties b2 e2 '(invisible t))
 223               (when multiline
 224                 (add-text-properties
 225                  beg e2 '(font-lock-multiline t))))))))))
 226
 227 (defun muse-colors-underlined ()
 228   (let ((start (match-beginning 0))
 229         multiline)
 230     (unless (get-text-property start 'invisible)
 231       ;; beginning of line or space or symbol
 232       (when (or (= start (point-min))
 233                 (memq (char-syntax (char-before start)) '(?\  ?\-))
 234                 (memq (char-before start)
 235                       '(?\- ?\[ ?\< ?\( ?\' ?\` ?\" ?\n)))
 236         (save-excursion
 237           (skip-chars-forward "^_<>\n" end)
 238           (when (eq (char-after) ?\n)
 239             (setq multiline t)
 240             (skip-chars-forward "^_<>" end))
 241           ;; Abort if space exists just before end
 242           ;; or no '_' at end
 243           (unless (or (eq (char-before (point)) ?\ )
 244                       (not (eq (char-after (point)) ?_)))
 245             (add-text-properties start (1+ start) '(invisible t))
 246             (add-text-properties (1+ start) (point) '(face underline))
 247             (add-text-properties (point)
 248                                  (min (1+ (point)) (point-max))
 249                                  '(invisible t))
 250             (when multiline
 251               (add-text-properties
 252                start (min (1+ (point)) (point-max))
 253                '(font-lock-multiline t)))))))))
 254
 255 (defun muse-colors-verbatim ()
 256   (skip-chars-forward (concat "^" muse-regexp-space "=>") end))
 257
 258 (defcustom muse-colors-markup
 259   `(;; render in teletype and suppress further parsing
 260     (,(concat "\\b=[^"
 261               muse-regexp-space
 262               "=>]")
 263      ?= muse-colors-verbatim)
 264
 265     ;; make emphasized text appear emphasized
 266     ("\\*\\{1,4\\}" ?* muse-colors-emphasized)
 267
 268     ;; make underlined text appear underlined
 269     (,(concat "_[^"
 270               muse-regexp-blank
 271               "_]")
 272      ?_ muse-colors-underlined)
 273
 274     ("^#title" ?\# muse-colors-title)
 275
 276     (muse-link-regexp ?\[ muse-colors-link)
 277
 278     ;; highlight any markup tags encountered
 279     (muse-tag-regexp ?\< muse-colors-custom-tags)
 280     )
 281   "Expressions to highlight an Emacs Muse buffer.
 282 These are arranged in a rather special fashion, so as to be as quick as
 283 possible.
 284
 285 Each element of the list is itself a list, of the form:
 286
 287   (LOCATE-REGEXP TEST-CHAR MATCH-FUNCTION)
 288
 289 LOCATE-REGEXP is a partial regexp, and should be the smallest possible
 290 regexp to differentiate this rule from other rules.  It may also be a
 291 symbol containing such a regexp.  The buffer region is scanned only
 292 once, and LOCATE-REGEXP indicates where the scanner should stop to
 293 look for highlighting possibilities.
 294
 295 TEST-CHAR is a char or t.  The character should match the beginning
 296 text matched by LOCATE-REGEXP.  These chars are used to build a vector
 297 for fast MATCH-FUNCTION calling.
 298
 299 MATCH-FUNCTION is the function called when a region has been
 300 identified.  It is responsible for adding the appropriate text
 301 properties to change the appearance of the buffer.
 302
 303 This markup is used to modify the appearance of the original text to
 304 make it look more like the published HTML would look (like making some
 305 markup text invisible, inlining images, etc).
 306
 307 font-lock is used to apply the markup rules, so that they can happen
 308 on a deferred basis.  They are not always accurate, but you can use
 309 \\[font-lock-fontifty-block] near the point of error to force
 310 fontification in that area.
 311
 312 Lastly, none of the regexp should contain grouping elements that will
 313 affect the match data results."
 314   :type '(repeat
 315           (list :tag "Highlight rule"
 316                 (choice (regexp :tag "Locate regexp")
 317                         (symbol :tag "Regexp symbol"))
 318                 (choice (character :tag "Confirm character")
 319                         (const :tag "Default rule" t))
 320                 function))
 321   :set 'muse-configure-highlighting
 322   :group 'muse-colors)
 323
 324 ;; XEmacs users don't have `font-lock-multiline'.
 325 (unless (boundp 'font-lock-multiline)
 326   (defvar font-lock-multiline nil))
 327
 328 (defun muse-use-font-lock ()
 329   (set (make-local-variable 'font-lock-multiline) 'undecided)
 330   (set (make-local-variable 'font-lock-defaults)
 331        `(nil t nil nil 'beginning-of-line
 332          (font-lock-fontify-region-function . muse-colors-region)
 333          (font-lock-unfontify-region-function
 334           . muse-unhighlight-region)))
 335   (set (make-local-variable 'font-lock-fontify-region-function)
 336        'muse-colors-region)
 337   (set (make-local-variable 'font-lock-unfontify-region-function)
 338        'muse-unhighlight-region)
 339   (muse-make-faces)
 340   (font-lock-mode t))
 341
 342 (defun muse-colors-buffer ()
 343   "Re-highlight the entire Muse buffer."
 344   (interactive)
 345   (muse-colors-region (point-min) (point-max) t))
 346
 347 (defun muse-colors-region (beg end &optional verbose)
 348   "Apply highlighting according to `muse-colors-markup'.
 349 Note that this function should NOT change the buffer, nor should any
 350 of the functions listed in `muse-colors-markup'."
 351   (let ((buffer-undo-list t)
 352         (inhibit-read-only t)
 353         (inhibit-point-motion-hooks t)
 354         (inhibit-modification-hooks t)
 355         (modified-p (buffer-modified-p))
 356         deactivate-mark)
 357     (unwind-protect
 358         (save-excursion
 359           (save-restriction
 360             (widen)
 361             ;; check to see if we should expand the beg/end area for
 362             ;; proper multiline matches
 363             (when (and font-lock-multiline
 364                        (> beg (point-min))
 365                        (get-text-property (1- beg) 'font-lock-multiline))
 366               ;; We are just after or in a multiline match.
 367               (setq beg (or (previous-single-property-change
 368                              beg 'font-lock-multiline)
 369                             (point-min)))
 370               (goto-char beg)
 371               (setq beg (line-beginning-position)))
 372             (when font-lock-multiline
 373               (setq end (or (text-property-any end (point-max)
 374                                                'font-lock-multiline nil)
 375                             (point-max))))
 376             (goto-char end)
 377             (setq end (line-beginning-position 2))
 378             ;; Undo any fontification in the area.
 379             (font-lock-unfontify-region beg end)
 380             ;; And apply fontification based on `muse-colors-markup'
 381             (let ((len (float (- end beg)))
 382                   (case-fold-search nil)
 383                   markup-func)
 384               (goto-char beg)
 385               (while (re-search-forward muse-colors-regexp end t)
 386                 (if verbose
 387                     (message "Highlighting buffer...%d%%"
 388                              (* (/ (float (- (point) beg)) len) 100)))
 389                 (setq markup-func
 390                       (aref muse-colors-vector
 391                             (char-after (match-beginning 0))))
 392                 (when markup-func (funcall markup-func)))
 393               (run-hook-with-args 'muse-colors-buffer-hook
 394                                   beg end verbose)
 395               (if verbose (message "Highlighting buffer...done")))))
 396       (set-buffer-modified-p modified-p))))
 397
 398 (defcustom muse-colors-tags
 399   '(("example" t nil muse-colors-example-tag))
 400   "A list of tag specifications for specially highlighting text.
 401 XML-style tags are the best way to add custom highlighting to Muse.
 402 This is easily accomplished by customizing this list of markup tags.
 403
 404 For each entry, the name of the tag is given, whether it expects
 405 a closing tag and/or an optional set of attributes, and a
 406 function that performs whatever action is desired within the
 407 delimited region.
 408
 409 The function is called with three arguments, the beginning and
 410 end of the region surrounded by the tags. If properties are
 411 allowed, they are passed as a third argument in the form of an
 412 alist. The `end' argument to the function is the last character
 413 of the enclosed tag or region.
 414
 415 Functions should not modify the contents of the buffer."
 416   :type '(repeat (list (string :tag "Markup tag")
 417                        (boolean :tag "Expect closing tag" :value t)
 418                        (boolean :tag "Parse attributes" :value nil)
 419                        function))
 420   :group 'muse-colors)
 421
 422 (defsubst muse-colors-tag-info (tagname &rest args)
 423   (assoc tagname muse-colors-tags))
 424
 425 (defun muse-colors-custom-tags ()
 426   "Highlight `muse-colors-tags'."
 427   (let ((tag-info (muse-colors-tag-info (match-string 4))))
 428     (when tag-info
 429       (let ((closed-tag (match-string 3))
 430             (start (match-beginning 0))
 431             (beg (point)) end attrs)
 432         (when (nth 2 tag-info)
 433           (let ((attrstr (match-string 2)))
 434             (while (and attrstr
 435                         (string-match (concat "\\([^"
 436                                               muse-regexp-space
 437                                               "=]+\\)\\(=\""
 438                                               "\\([^\"]+\\)\"\\)?")
 439                                       attrstr))
 440               (let ((attr (cons (downcase
 441                                  (match-string-no-properties 1 attrstr))
 442                                 (match-string-no-properties 3 attrstr))))
 443                 (setq attrstr (replace-match "" t t attrstr))
 444                 (if attrs
 445                     (nconc attrs (list attr))
 446                   (setq attrs (list attr)))))))
 447         (if (and (cadr tag-info) (not closed-tag))
 448             (if (search-forward (concat "</" (car tag-info) ">") nil t)
 449                 (setq end (match-end 0))
 450               (setq tag-info nil)))
 451         (when tag-info
 452           (let ((args (list start end)))
 453             (if (nth 2 tag-info)
 454                 (nconc args (list attrs)))
 455             (apply (nth 3 tag-info) args)))))))
 456
 457 (defun muse-colors-example-tag (beg end)
 458   "Strip properties from stuff in example."
 459   (set-text-properties beg end nil)
 460   (goto-char end))
 461
 462 (defun muse-unhighlight-region (begin end &optional verbose)
 463   "Remove all visual highlights in the buffer (except font-lock)."
 464   (let ((buffer-undo-list t)
 465         (inhibit-read-only t)
 466         (inhibit-point-motion-hooks t)
 467         (inhibit-modification-hooks t)
 468         (modified-p (buffer-modified-p))
 469         deactivate-mark)
 470     (unwind-protect
 471         (remove-text-properties
 472          begin end '(face nil font-lock-multiline nil
 473                           invisible nil intangible nil display nil
 474                           mouse-face nil keymap nil help-echo nil))
 475       (set-buffer-modified-p modified-p))))
 476
 477 (defvar muse-mode-local-map
 478   (let ((map (make-sparse-keymap)))
 479     (define-key map [return] 'muse-follow-name-at-point)
 480     (define-key map [(control ?m)] 'muse-follow-name-at-point)
 481     (define-key map [(shift return)] 'muse-follow-name-at-point-other-window)
 482     (if (featurep 'xemacs)
 483         (progn
 484           (define-key map [(button2)] 'muse-follow-name-at-mouse)
 485           (define-key map [(shift button2)] 'muse-follow-name-at-mouse-other-window))
 486       (define-key map [(shift control ?m)] 'muse-follow-name-at-point-other-window)
 487       (define-key map [mouse-2] 'muse-follow-name-at-mouse)
 488       (define-key map [(shift mouse-2)] 'muse-follow-name-at-mouse-other-window)
 489       (unless (eq emacs-major-version 21)
 490         (set-keymap-parent map muse-mode-map)))
 491     map)
 492   "Local keymap used by Muse while on a link.")
 493
 494 (defvar muse-keymap-property
 495   (if (or (featurep 'xemacs)
 496           (>= emacs-major-version 21))
 497       'keymap
 498     'local-map))
 499
 500 (defsubst muse-link-properties (help-str &optional face)
 501   (append (if face
 502               (list 'face face 'rear-nonsticky t
 503                     muse-keymap-property muse-mode-local-map)
 504             (list 'invisible t 'intangible t 'rear-nonsticky t
 505                   muse-keymap-property muse-mode-local-map))
 506           (list 'mouse-face 'highlight
 507                 'help-echo help-str
 508                 muse-keymap-property muse-mode-local-map)))
 509
 510 (defun muse-link-face (link-name)
 511   "Return the type of LINK-NAME as a face symbol - either a normal link, or a
 512 bad-link face"
 513   (save-match-data
 514     (if (or (string-match muse-file-regexp link-name)
 515             (string-match muse-url-regexp link-name))
 516         'muse-link-face
 517       (if (not (featurep 'muse-project))
 518           'muse-link-face
 519         (if (string-match "#" link-name)
 520             (setq link-name (substring link-name 0 (match-beginning 0))))
 521         (if (or (and (muse-project-of-file)
 522                      (muse-project-page-file link-name muse-current-project t))
 523                 (file-exists-p link-name))
 524             'muse-link-face
 525           'muse-bad-link-face)))))
 526
 527 (defun muse-colors-link ()
 528   (when (eq ?\[ (char-after (match-beginning 0)))
 529     ;; remove flyspell overlays
 530     (when (fboundp 'flyspell-unhighlight-at)
 531       (let ((cur (match-beginning 0)))
 532         (while (> (match-end 0) cur)
 533           (flyspell-unhighlight-at cur)
 534           (setq cur (1+ cur)))))
 535     (let* ((link (match-string-no-properties 2))
 536            (desc (match-string-no-properties 3))
 537            (props (muse-link-properties
 538                    desc (muse-link-face (match-string 2))))
 539            (invis-props (append props (muse-link-properties desc))))
 540       (if desc
 541           (progn
 542             ;; we put the normal face properties on the invisible
 543             ;; portion too, since emacs sometimes will position
 544             ;; the cursor on an intangible character
 545             (add-text-properties (match-beginning 0)
 546                                  (match-beginning 3) invis-props)
 547             (add-text-properties (match-beginning 3) (match-end 3) props)
 548             (add-text-properties (match-end 3) (match-end 0) invis-props))
 549         (add-text-properties (match-beginning 0)
 550                              (match-beginning 2) invis-props)
 551         (add-text-properties (match-beginning 2) (match-end 0) props)
 552         (add-text-properties (match-end 2) (match-end 0) invis-props)))
 553     (goto-char (match-end 0))
 554     (add-text-properties
 555      (match-beginning 0) (match-end 0)
 556      (muse-link-properties (match-string-no-properties 0)
 557                            (muse-link-face (match-string 2))))
 558     (goto-char (match-end 0))))
 559
 560 (defun muse-colors-title ()
 561   (add-text-properties (+ 7 (match-beginning 0))
 562                        (line-end-position)
 563                        '(face muse-header-1)))
 564
 565 (provide 'muse-colors)
 566
 567 ;;; muse-colors.el ends here