lisp/hi-lock.el

   1 ;;; hi-lock.el --- minor mode for interactive automatic highlighting
   2
   3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005 Free Software Foundation, Inc.
   5
   6 ;; Author: David M. Koppelman, koppel@ee.lsu.edu
   7 ;; Keywords: faces, minor-mode, matching, display
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; 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 ;;  With the hi-lock commands text matching interactively entered
  29 ;;  regexp's can be highlighted.  For example, `M-x highlight-regexp
  30 ;;  RET clearly RET RET' will highlight all occurrences of `clearly'
  31 ;;  using a yellow background face.  New occurrences of `clearly' will
  32 ;;  be highlighted as they are typed.  `M-x unhighlight-regexp RET'
  33 ;;  will remove the highlighting.  Any existing face can be used for
  34 ;;  highlighting and a set of appropriate faces is provided.  The
  35 ;;  regexps can be written into the current buffer in a form that will
  36 ;;  be recognized the next time the corresponding file is read.
  37 ;;
  38 ;;  Applications:
  39 ;;
  40 ;;    In program source code highlight a variable to quickly see all
  41 ;;    places it is modified or referenced:
  42 ;;    M-x highlight-regexp ground_contact_switches_closed RET RET
  43 ;;
  44 ;;    In a shell or other buffer that is showing lots of program
  45 ;;    output, highlight the parts of the output you're interested in:
  46 ;;    M-x highlight-regexp Total execution time [0-9]+ RET hi-blue-b RET
  47 ;;
  48 ;;    In buffers displaying tables, highlight the lines you're interested in:
  49 ;;    M-x highlight-lines-matching-regexp January 2000 RET hi-black-b RET
  50 ;;
  51 ;;    When writing text, highlight personal cliches.  This can be
  52 ;;    amusing.
  53 ;;    M-x highlight-phrase as can be seen RET RET
  54 ;;
  55 ;;  Setup:
  56 ;;
  57 ;;    Put the following code in your .emacs file.  This turns on
  58 ;;    hi-lock mode and adds a "Regexp Highlighting" entry
  59 ;;    to the edit menu.
  60 ;;
  61 ;;    (hi-lock-mode 1)
  62 ;;
  63 ;;    You might also want to bind the hi-lock commands to more
  64 ;;    finger-friendly sequences:
  65
  66 ;;    (define-key hi-lock-map "\C-z\C-h" 'highlight-lines-matching-regexp)
  67 ;;    (define-key hi-lock-map "\C-zi" 'hi-lock-find-patterns)
  68 ;;    (define-key hi-lock-map "\C-zh" 'highlight-regexp)
  69 ;;    (define-key hi-lock-map "\C-zp" 'highlight-phrase)
  70 ;;    (define-key hi-lock-map "\C-zr" 'unhighlight-regexp)
  71 ;;    (define-key hi-lock-map "\C-zb" 'hi-lock-write-interactive-patterns))
  72
  73 ;;    See the documentation for hi-lock-mode `C-h f hi-lock-mode' for
  74 ;;    additional instructions.
  75
  76 ;; Sample file patterns:
  77
  78 ; Hi-lock: (("^;;; .*" (0 (quote hi-black-hb) t)))
  79 ; Hi-lock: ( ("make-variable-buffer-\\(local\\)" (0 font-lock-keyword-face)(1 'italic append)))))
  80 ; Hi-lock: end
  81
  82 ;;; Code:
  83
  84 (eval-and-compile
  85   (require 'font-lock))
  86
  87 (defgroup hi-lock nil
  88   "Interactively add and remove font-lock patterns for highlighting text."
  89   :link '(custom-manual "(emacs)Highlight Interactively")
  90   :group 'font-lock)
  91
  92 ;;;###autoload
  93 (defcustom hi-lock-mode nil
  94   "Toggle hi-lock, for interactively adding font-lock text-highlighting patterns."
  95   :set (lambda (symbol value)
  96          (hi-lock-mode (or value 0)))
  97   :initialize 'custom-initialize-default
  98   :type 'boolean
  99   :group 'hi-lock
 100   :require 'hi-lock)
 101
 102 (defcustom hi-lock-file-patterns-range 10000
 103   "Limit of search in a buffer for hi-lock patterns.
 104 When a file is visited and hi-lock mode is on patterns starting
 105 up to this limit are added to font-lock's patterns.  See documentation
 106 of functions `hi-lock-mode' and `hi-lock-find-patterns'."
 107   :type 'integer
 108   :group 'hi-lock)
 109
 110 (defcustom hi-lock-exclude-modes
 111   '(rmail-mode mime/viewer-mode gnus-article-mode)
 112   "List of major modes in which hi-lock will not run.
 113 For security reasons since font lock patterns can specify function
 114 calls."
 115   :type '(repeat symbol)
 116   :group 'hi-lock)
 117
 118
 119 (defgroup hi-lock-faces nil
 120   "Faces for hi-lock."
 121   :group 'hi-lock
 122   :group 'faces)
 123
 124 (defface hi-yellow
 125   '((((min-colors 88) (background dark))
 126      (:background "yellow1" :foreground "black"))
 127     (((background dark)) (:background "yellow" :foreground "black"))
 128     (((min-colors 88)) (:background "yellow1"))
 129     (t (:background "yellow")))
 130   "Default face for hi-lock mode."
 131   :group 'hi-lock-faces)
 132
 133 (defface hi-pink
 134   '((((background dark)) (:background "pink" :foreground "black"))
 135     (t (:background "pink")))
 136   "Face for hi-lock mode."
 137   :group 'hi-lock-faces)
 138
 139 (defface hi-green
 140   '((((min-colors 88) (background dark))
 141      (:background "green1" :foreground "black"))
 142     (((background dark)) (:background "green" :foreground "black"))
 143     (((min-colors 88)) (:background "green1"))
 144     (t (:background "green")))
 145   "Face for hi-lock mode."
 146   :group 'hi-lock-faces)
 147
 148 (defface hi-blue
 149   '((((background dark)) (:background "light blue" :foreground "black"))
 150     (t (:background "light blue")))
 151   "Face for hi-lock mode."
 152   :group 'hi-lock-faces)
 153
 154 (defface hi-black-b
 155   '((t (:weight bold)))
 156   "Face for hi-lock mode."
 157   :group 'hi-lock-faces)
 158
 159 (defface hi-blue-b
 160   '((((min-colors 88)) (:weight bold :foreground "blue1"))
 161     (t (:weight bold :foreground "blue")))
 162   "Face for hi-lock mode."
 163   :group 'hi-lock-faces)
 164
 165 (defface hi-green-b
 166   '((((min-colors 88)) (:weight bold :foreground "green1"))
 167     (t (:weight bold :foreground "green")))
 168   "Face for hi-lock mode."
 169   :group 'hi-lock-faces)
 170
 171 (defface hi-red-b
 172   '((((min-colors 88)) (:weight bold :foreground "red1"))
 173     (t (:weight bold :foreground "red")))
 174   "Face for hi-lock mode."
 175   :group 'hi-lock-faces)
 176
 177 (defface hi-black-hb
 178   '((t (:weight bold :height 1.67 :inherit variable-pitch)))
 179   "Face for hi-lock mode."
 180   :group 'hi-lock-faces)
 181
 182 (defvar hi-lock-file-patterns nil
 183   "Patterns found in file for hi-lock.  Should not be changed.")
 184
 185 (defvar hi-lock-interactive-patterns nil
 186   "Patterns provided to hi-lock by user.  Should not be changed.")
 187
 188 (defvar hi-lock-face-history
 189   (list "hi-yellow" "hi-pink" "hi-green" "hi-blue" "hi-black-b"
 190         "hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb")
 191       "History list of faces for hi-lock interactive functions.")
 192
 193 ;(dolist (f hi-lock-face-history) (unless (facep f) (error "%s not a face" f)))
 194
 195 (defvar hi-lock-regexp-history nil
 196   "History of regexps used for interactive fontification.")
 197
 198 (defvar hi-lock-file-patterns-prefix "Hi-lock"
 199   "Regexp for finding hi-lock patterns at top of file.")
 200
 201 (make-variable-buffer-local 'hi-lock-interactive-patterns)
 202 (put 'hi-lock-interactive-patterns 'permanent-local t)
 203 (make-variable-buffer-local 'hi-lock-regexp-history)
 204 (put 'hi-lock-regexp-history 'permanent-local t)
 205 (make-variable-buffer-local 'hi-lock-file-patterns)
 206 (put 'hi-lock-file-patterns 'permanent-local t)
 207
 208 (defvar hi-lock-menu (make-sparse-keymap "Hi Lock")
 209   "Menu for hi-lock mode.")
 210
 211 (define-key-after hi-lock-menu [highlight-regexp]
 212   '(menu-item "Highlight Regexp..." highlight-regexp
 213               :help "Highlight text matching PATTERN (a regexp)."))
 214
 215 (define-key-after hi-lock-menu [highlight-phrase]
 216   '(menu-item "Highlight Phrase..." highlight-phrase
 217               :help "Highlight text matching PATTERN (a regexp processed to match phrases)."))
 218
 219 (define-key-after hi-lock-menu [highlight-lines-matching-regexp]
 220   '(menu-item "Highlight Lines..." highlight-lines-matching-regexp
 221               :help "Highlight lines containing match of PATTERN (a regexp).."))
 222
 223 (define-key-after hi-lock-menu [unhighlight-regexp]
 224   '(menu-item "Remove Highlighting..." unhighlight-regexp
 225               :help "Remove previously entered highlighting pattern."
 226               :enable hi-lock-interactive-patterns))
 227
 228 (define-key-after hi-lock-menu [hi-lock-write-interactive-patterns]
 229   '(menu-item "Patterns to Buffer" hi-lock-write-interactive-patterns
 230               :help "Insert interactively added REGEXPs into buffer at point."
 231               :enable hi-lock-interactive-patterns))
 232
 233 (define-key-after hi-lock-menu [hi-lock-find-patterns]
 234   '(menu-item "Patterns from Buffer" hi-lock-find-patterns
 235               :help "Use patterns (if any) near top of buffer."))
 236
 237 (defvar hi-lock-map (make-sparse-keymap "Hi Lock")
 238   "Key map for hi-lock.")
 239
 240 (define-key hi-lock-map "\C-xwi" 'hi-lock-find-patterns)
 241 (define-key hi-lock-map "\C-xwl" 'highlight-lines-matching-regexp)
 242 (define-key hi-lock-map "\C-xwp" 'highlight-phrase)
 243 (define-key hi-lock-map "\C-xwh" 'highlight-regexp)
 244 (define-key hi-lock-map "\C-xwr" 'unhighlight-regexp)
 245 (define-key hi-lock-map "\C-xwb" 'hi-lock-write-interactive-patterns)
 246
 247 (unless (assq 'hi-lock-mode minor-mode-map-alist)
 248   (setq minor-mode-map-alist (cons (cons 'hi-lock-mode hi-lock-map)
 249                                    minor-mode-map-alist)))
 250
 251 (unless (assq 'hi-lock-mode minor-mode-alist)
 252   (setq minor-mode-alist (cons '(hi-lock-mode " H") minor-mode-alist)))
 253
 254
 255 ;; Visible Functions
 256
 257
 258 ;;;###autoload
 259 (defun hi-lock-mode (&optional arg)
 260   "Toggle minor mode for interactively adding font-lock highlighting patterns.
 261
 262 If ARG positive turn hi-lock on.  Issuing a hi-lock command will also
 263 turn hi-lock on.  When hi-lock is turned on, a \"Regexp Highlighting\"
 264 submenu is added to the \"Edit\" menu.  The commands in the submenu,
 265 which can be called interactively, are:
 266
 267 \\[highlight-regexp] REGEXP FACE
 268   Highlight matches of pattern REGEXP in current buffer with FACE.
 269
 270 \\[highlight-phrase] PHRASE FACE
 271   Highlight matches of phrase PHRASE in current buffer with FACE.
 272   (PHRASE can be any REGEXP, but spaces will be replaced by matches
 273   to whitespace and initial lower-case letters will become case insensitive.)
 274
 275 \\[highlight-lines-matching-regexp] REGEXP FACE
 276   Highlight lines containing matches of REGEXP in current buffer with FACE.
 277
 278 \\[unhighlight-regexp] REGEXP
 279   Remove highlighting on matches of REGEXP in current buffer.
 280
 281 \\[hi-lock-write-interactive-patterns]
 282   Write active REGEXPs into buffer as comments (if possible). They will
 283   be read the next time file is loaded or when the \\[hi-lock-find-patterns] command
 284   is issued.  The inserted regexps are in the form of font lock keywords.
 285   (See `font-lock-keywords') They may be edited and re-loaded with \\[hi-lock-find-patterns],
 286   any valid `font-lock-keywords' form is acceptable.
 287
 288 \\[hi-lock-find-patterns]
 289   Re-read patterns stored in buffer (in the format produced by \\[hi-lock-write-interactive-patterns]).
 290
 291 When hi-lock is started and if the mode is not excluded, the
 292 beginning of the buffer is searched for lines of the form:
 293   Hi-lock: FOO
 294 where FOO is a list of patterns. These are added to the font lock keywords
 295 already present.  The patterns must start before position (number
 296 of characters into buffer) `hi-lock-file-patterns-range'.  Patterns
 297 will be read until
 298  Hi-lock: end
 299 is found. A mode is excluded if it's in the list `hi-lock-exclude-modes'."
 300   (interactive)
 301   (let ((hi-lock-mode-prev hi-lock-mode))
 302     (setq hi-lock-mode
 303           (if (null arg) (not hi-lock-mode)
 304             (> (prefix-numeric-value arg) 0)))
 305     ;; Turned on.
 306     (when (and (not hi-lock-mode-prev) hi-lock-mode)
 307       (add-hook 'find-file-hook 'hi-lock-find-file-hook)
 308       (add-hook 'font-lock-mode-hook 'hi-lock-font-lock-hook)
 309       (if (null (default-value 'font-lock-defaults))
 310           (setq-default font-lock-defaults '(nil)))
 311       (if (null font-lock-defaults)
 312           (setq font-lock-defaults '(nil)))
 313       (unless font-lock-mode
 314         (font-lock-mode 1))
 315       (define-key-after menu-bar-edit-menu [hi-lock]
 316         (cons "Regexp Highlighting" hi-lock-menu))
 317       (dolist (buffer (buffer-list))
 318         (with-current-buffer buffer (hi-lock-find-patterns))))
 319     ;; Turned off.
 320     (when (and hi-lock-mode-prev (not hi-lock-mode))
 321       (dolist (buffer (buffer-list))
 322         (with-current-buffer buffer
 323           (when (or hi-lock-interactive-patterns hi-lock-file-patterns)
 324             (font-lock-remove-keywords nil hi-lock-interactive-patterns)
 325             (font-lock-remove-keywords nil hi-lock-file-patterns)
 326             (setq hi-lock-interactive-patterns nil
 327                   hi-lock-file-patterns nil)
 328             (when font-lock-mode (hi-lock-refontify)))))
 329
 330       (let ((fld (default-value 'font-lock-defaults)))
 331         (if (and fld (listp fld) (null (car fld)))
 332             (setq-default font-lock-defaults (cdr fld))))
 333       (define-key-after menu-bar-edit-menu [hi-lock] nil)
 334       (remove-hook 'find-file-hook 'hi-lock-find-file-hook)
 335       (remove-hook 'font-lock-mode-hook 'hi-lock-font-lock-hook))))
 336
 337
 338 ;;;###autoload
 339 (defalias 'highlight-lines-matching-regexp 'hi-lock-line-face-buffer)
 340 ;;;###autoload
 341 (defun hi-lock-line-face-buffer (regexp &optional face)
 342   "Set face of all lines containing a match of REGEXP to FACE.
 343
 344 Interactively, prompt for REGEXP then FACE.  Buffer-local history
 345 list maintained for regexps, global history maintained for faces.
 346 \\<minibuffer-local-map>Use \\[next-history-element] and \\[previous-history-element] to retrieve next or previous history item.
 347 \(See info node `Minibuffer History')"
 348   (interactive
 349    (list
 350     (hi-lock-regexp-okay
 351      (read-from-minibuffer "Regexp to highlight line: "
 352                            (cons (or (car hi-lock-regexp-history) "") 1 )
 353                            nil nil 'hi-lock-regexp-history))
 354     (hi-lock-read-face-name)))
 355   (unless hi-lock-mode (hi-lock-mode))
 356   (or (facep face) (setq face 'rwl-yellow))
 357   (hi-lock-set-pattern
 358    ;; The \\(?:...\\) grouping construct ensures that a leading ^, +, * or ?
 359    ;; or a trailing $ in REGEXP will be interpreted correctly.
 360    (list (concat "^.*\\(?:" regexp "\\).*$") (list 0 (list 'quote face) t))))
 361
 362
 363 ;;;###autoload
 364 (defalias 'highlight-regexp 'hi-lock-face-buffer)
 365 ;;;###autoload
 366 (defun hi-lock-face-buffer (regexp &optional face)
 367   "Set face of each match of REGEXP to FACE.
 368
 369 Interactively, prompt for REGEXP then FACE.  Buffer-local history
 370 list maintained for regexps, global history maintained for faces.
 371 \\<minibuffer-local-map>Use \\[next-history-element] and \\[previous-history-element] to retrieve next or previous history item.
 372 \(See info node `Minibuffer History')"
 373   (interactive
 374    (list
 375     (hi-lock-regexp-okay
 376      (read-from-minibuffer "Regexp to highlight: "
 377                            (cons (or (car hi-lock-regexp-history) "") 1 )
 378                            nil nil 'hi-lock-regexp-history))
 379     (hi-lock-read-face-name)))
 380   (or (facep face) (setq face 'rwl-yellow))
 381   (unless hi-lock-mode (hi-lock-mode))
 382   (hi-lock-set-pattern (list regexp (list 0 (list 'quote face) t))))
 383
 384 ;;;###autoload
 385 (defalias 'highlight-phrase 'hi-lock-face-phrase-buffer)
 386 ;;;###autoload
 387 (defun hi-lock-face-phrase-buffer (regexp &optional face)
 388   "Set face of each match of phrase REGEXP to FACE.
 389
 390 Whitespace in REGEXP converted to arbitrary whitespace and initial
 391 lower-case letters made case insensitive."
 392   (interactive
 393    (list
 394     (hi-lock-regexp-okay
 395      (hi-lock-process-phrase
 396       (read-from-minibuffer "Phrase to highlight: "
 397                             (cons (or (car hi-lock-regexp-history) "") 1 )
 398                             nil nil 'hi-lock-regexp-history)))
 399     (hi-lock-read-face-name)))
 400   (or (facep face) (setq face 'rwl-yellow))
 401   (unless hi-lock-mode (hi-lock-mode))
 402   (hi-lock-set-pattern (list regexp (list 0 (list 'quote face) t))))
 403
 404 ;;;###autoload
 405 (defalias 'unhighlight-regexp 'hi-lock-unface-buffer)
 406 ;;;###autoload
 407 (defun hi-lock-unface-buffer (regexp)
 408   "Remove highlighting of each match to REGEXP set by hi-lock.
 409
 410 Interactively, prompt for REGEXP.  Buffer-local history of inserted
 411 regexp's maintained.  Will accept only regexps inserted by hi-lock
 412 interactive functions.  \(See `hi-lock-interactive-patterns'.\)
 413 \\<minibuffer-local-must-match-map>Use \\[minibuffer-complete] to complete a partially typed regexp.
 414 \(See info node `Minibuffer History'.\)"
 415   (interactive
 416    (if (and (display-popup-menus-p) (vectorp (this-command-keys)))
 417        (catch 'snafu
 418          (or
 419           (x-popup-menu
 420            t
 421            (cons
 422             `keymap
 423             (cons "Select Pattern to Unhighlight"
 424                   (mapcar (lambda (pattern)
 425                             (list (car pattern)
 426                                   (format
 427                                    "%s (%s)" (car pattern)
 428                                    (symbol-name
 429                                     (car
 430                                      (cdr (car (cdr (car (cdr pattern))))))))
 431                                   (cons nil nil)
 432                                   (car pattern)))
 433                           hi-lock-interactive-patterns))))
 434           ;; If the user clicks outside the menu, meaning that they
 435           ;; change their mind, x-popup-menu returns nil, and
 436           ;; interactive signals a wrong number of arguments error.
 437           ;; To prevent that, we return an empty string, which will
 438           ;; effectively disable the rest of the function.
 439           (throw 'snafu '(""))))
 440      (let ((history-list (mapcar (lambda (p) (car p))
 441                                  hi-lock-interactive-patterns)))
 442        (unless hi-lock-interactive-patterns
 443          (error "No highlighting to remove"))
 444        (list
 445         (completing-read "Regexp to unhighlight: "
 446                          hi-lock-interactive-patterns nil t
 447                          (car (car hi-lock-interactive-patterns))
 448                          (cons 'history-list 1))))))
 449   (let ((keyword (assoc regexp hi-lock-interactive-patterns)))
 450     (when keyword
 451       (font-lock-remove-keywords nil (list keyword))
 452       (setq hi-lock-interactive-patterns
 453             (delq keyword hi-lock-interactive-patterns))
 454       (hi-lock-refontify))))
 455
 456 ;;;###autoload
 457 (defun hi-lock-write-interactive-patterns ()
 458   "Write interactively added patterns, if any, into buffer at point.
 459
 460 Interactively added patterns are those normally specified using
 461 `highlight-regexp' and `highlight-lines-matching-regexp'; they can
 462 be found in variable `hi-lock-interactive-patterns'."
 463   (interactive)
 464   (let ((prefix (format "%s %s:" (or comment-start "") "Hi-lock")))
 465     (when (> (+ (point) (length prefix)) hi-lock-file-patterns-range)
 466       (beep)
 467       (message
 468        "Warning, inserted keywords not close enough to top of file."))
 469     (mapcar
 470      (lambda (pattern)
 471        (insert (format "%s (%s) %s\n"
 472                        prefix (prin1-to-string pattern) (or comment-end ""))))
 473      hi-lock-interactive-patterns)))
 474
 475
 476 ;; Implementation Functions
 477
 478 (defun hi-lock-process-phrase (phrase)
 479   "Convert regexp PHRASE to a regexp that matches phrases.
 480
 481 Blanks in PHRASE replaced by regexp that matches arbitrary whitespace
 482 and initial lower-case letters made case insensitive."
 483   (let ((mod-phrase nil))
 484     (setq mod-phrase
 485           (replace-regexp-in-string
 486            "\\<[a-z]" (lambda (m) (format "[%s%s]" (upcase m) m)) phrase))
 487     (setq mod-phrase
 488           (replace-regexp-in-string
 489            "\\s-+" "[ \t\n]+" mod-phrase nil t))))
 490
 491 (defun hi-lock-regexp-okay (regexp)
 492   "Return REGEXP if it appears suitable for a font-lock pattern.
 493
 494 Otherwise signal an error.  A pattern that matches the null string is
 495 not suitable."
 496   (if (string-match regexp "")
 497       (error "Regexp cannot match an empty string")
 498     regexp))
 499
 500 (defun hi-lock-read-face-name ()
 501   "Read face name from minibuffer with completion and history."
 502   (intern (completing-read
 503            "Highlight using face: "
 504            obarray 'facep t
 505            (cons (car hi-lock-face-history)
 506                  (let ((prefix
 507                         (try-completion
 508                          (substring (car hi-lock-face-history) 0 1)
 509                          (mapcar (lambda (f) (cons f f))
 510                                  hi-lock-face-history))))
 511                    (if (and (stringp prefix)
 512                             (not (equal prefix (car hi-lock-face-history))))
 513                        (length prefix) 0)))
 514            '(hi-lock-face-history . 0))))
 515
 516 (defun hi-lock-find-file-hook ()
 517   "Add hi-lock patterns, if present."
 518   (hi-lock-find-patterns))
 519
 520 (defun hi-lock-current-line (&optional end)
 521   "Return line number of line at point.
 522 Optional argument END is maximum excursion."
 523   (interactive)
 524   (save-excursion
 525     (beginning-of-line)
 526     (1+ (count-lines 1 (or end (point))))))
 527
 528 (defun hi-lock-set-pattern (pattern)
 529   "Add PATTERN to list of interactively highlighted patterns and refontify."
 530   (hi-lock-set-patterns (list pattern)))
 531
 532 (defun hi-lock-set-patterns (patterns)
 533   "Add PATTERNS to list of interactively highlighted patterns and refontify.."
 534   (dolist (pattern patterns)
 535     (unless (member pattern hi-lock-interactive-patterns)
 536       (font-lock-add-keywords nil (list pattern))
 537       (add-to-list 'hi-lock-interactive-patterns pattern)))
 538   (hi-lock-refontify))
 539
 540 (defun hi-lock-set-file-patterns (patterns)
 541   "Replace file patterns list with PATTERNS and refontify."
 542   (when (or hi-lock-file-patterns patterns)
 543     (font-lock-remove-keywords nil hi-lock-file-patterns)
 544     (setq hi-lock-file-patterns patterns)
 545     (font-lock-add-keywords nil hi-lock-file-patterns)
 546     (hi-lock-refontify)))
 547
 548 (defun hi-lock-refontify ()
 549   "Unfontify then refontify buffer.  Used when hi-lock patterns change."
 550   (interactive)
 551   (unless font-lock-mode (font-lock-mode 1))
 552   (font-lock-fontify-buffer))
 553
 554 (defun hi-lock-find-patterns ()
 555   "Find patterns in current buffer for hi-lock."
 556   (interactive)
 557   (unless (memq major-mode hi-lock-exclude-modes)
 558     (let ((all-patterns nil)
 559           (target-regexp (concat "\\<" hi-lock-file-patterns-prefix ":")))
 560       (save-excursion
 561         (save-restriction
 562           (widen)
 563           (goto-char (point-min))
 564           (re-search-forward target-regexp
 565                              (+ (point) hi-lock-file-patterns-range) t)
 566           (beginning-of-line)
 567           (while (and (re-search-forward target-regexp (+ (point) 100) t)
 568                       (not (looking-at "\\s-*end")))
 569             (condition-case nil
 570                 (setq all-patterns (append (read (current-buffer)) all-patterns))
 571               (error (message "Invalid pattern list expression at %d"
 572                               (hi-lock-current-line)))))))
 573       (when hi-lock-mode (hi-lock-set-file-patterns all-patterns))
 574       (if (interactive-p)
 575         (message "Hi-lock added %d patterns." (length all-patterns))))))
 576
 577 (defun hi-lock-font-lock-hook ()
 578   "Add hi lock patterns to font-lock's."
 579   (when hi-lock-mode
 580     (font-lock-add-keywords nil hi-lock-file-patterns)
 581     (font-lock-add-keywords nil hi-lock-interactive-patterns)))
 582
 583 (provide 'hi-lock)
 584
 585 ;; arch-tag: d2e8fd07-4cc9-4c6f-a200-1e729bc54066
 586 ;;; hi-lock.el ends here