code.delx.au - gnu-emacs/blob - lisp/hi-lock.el

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