1;;; hi-lock.el --- minor mode for interactive automatic highlighting
2
3;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
4;;   2005, 2006, 2007 Free Software Foundation, Inc.
5
6;; Author: David M. Koppelman, koppel@ece.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 (when
37;;  file patterns is turned on).
38;;
39;;  Applications:
40;;
41;;    In program source code highlight a variable to quickly see all
42;;    places it is modified or referenced:
43;;    M-x highlight-regexp ground_contact_switches_closed RET RET
44;;
45;;    In a shell or other buffer that is showing lots of program
46;;    output, highlight the parts of the output you're interested in:
47;;    M-x highlight-regexp Total execution time [0-9]+ RET hi-blue-b RET
48;;
49;;    In buffers displaying tables, highlight the lines you're interested in:
50;;    M-x highlight-lines-matching-regexp January 2000 RET hi-black-b RET
51;;
52;;    When writing text, highlight personal cliches.  This can be
53;;    amusing.
54;;    M-x highlight-phrase as can be seen RET RET
55;;
56;;  Setup:
57;;
58;;    Put the following code in your .emacs file.  This turns on
59;;    hi-lock mode and adds a "Regexp Highlighting" entry
60;;    to the edit menu.
61;;
62;;    (global-hi-lock-mode 1)
63;;
64;;    To enable the use of patterns found in files (presumably placed
65;;    there by hi-lock) include the following in your .emacs file:
66;;
67;;    (setq hi-lock-file-patterns-policy 'ask)
68;;
69;;    If you get tired of being asked each time a file is loaded replace
70;;    `ask' with a function that returns t if patterns should be read.
71;;
72;;    You might also want to bind the hi-lock commands to more
73;;    finger-friendly sequences:
74
75;;    (define-key hi-lock-map "\C-z\C-h" 'highlight-lines-matching-regexp)
76;;    (define-key hi-lock-map "\C-zi" 'hi-lock-find-patterns)
77;;    (define-key hi-lock-map "\C-zh" 'highlight-regexp)
78;;    (define-key hi-lock-map "\C-zp" 'highlight-phrase)
79;;    (define-key hi-lock-map "\C-zr" 'unhighlight-regexp)
80;;    (define-key hi-lock-map "\C-zb" 'hi-lock-write-interactive-patterns))
81
82;;    See the documentation for hi-lock-mode `C-h f hi-lock-mode' for
83;;    additional instructions.
84
85;; Sample file patterns:
86
87; Hi-lock: (("^;;; .*" (0 (quote hi-black-hb) t)))
88; Hi-lock: ( ("make-variable-buffer-\\(local\\)" (0 font-lock-keyword-face)(1 'italic append)))))
89; Hi-lock: end
90
91;;; Code:
92
93(eval-and-compile
94  (require 'font-lock))
95
96(defgroup hi-lock nil
97  "Interactively add and remove font-lock patterns for highlighting text."
98  :link '(custom-manual "(emacs)Highlight Interactively")
99  :group 'font-lock)
100
101(defcustom hi-lock-file-patterns-range 10000
102  "Limit of search in a buffer for hi-lock patterns.
103When a file is visited and hi-lock mode is on, patterns starting
104up to this limit are added to font-lock's patterns.  See documentation
105of functions `hi-lock-mode' and `hi-lock-find-patterns'."
106  :type 'integer
107  :group 'hi-lock)
108
109(defcustom hi-lock-highlight-range 200000
110  "Size of area highlighted by hi-lock when font-lock not active.
111Font-lock is not active in buffers that do their own highlighting,
112such as the buffer created by `list-colors-display'.  In those buffers
113hi-lock patterns will only be applied over a range of
114`hi-lock-highlight-range' characters.  If font-lock is active then
115highlighting will be applied throughout the buffer."
116  :type 'integer
117  :group 'hi-lock)
118
119(defcustom hi-lock-exclude-modes
120  '(rmail-mode mime/viewer-mode gnus-article-mode)
121  "List of major modes in which hi-lock will not run.
122For security reasons since font lock patterns can specify function
123calls."
124  :type '(repeat symbol)
125  :group 'hi-lock)
126
127(defcustom hi-lock-file-patterns-policy 'ask
128  "Specify when hi-lock should use patterns found in file.
129If `ask', prompt when patterns found in buffer; if bound to a function,
130use patterns when function returns t (function is called with patterns
131as first argument); if nil or `never' or anything else, don't use file
132patterns."
133  :type '(choice (const :tag "Do not use file patterns" never)
134                 (const :tag "Ask about file patterns" ask)
135                 (function :tag "Function to check file patterns"))
136  :group 'hi-lock
137  :version "22.1")
138
139;; It can have a function value.
140(put 'hi-lock-file-patterns-policy 'risky-local-variable t)
141
142(defgroup hi-lock-faces nil
143  "Faces for hi-lock."
144  :group 'hi-lock
145  :group 'faces)
146
147(defface hi-yellow
148  '((((min-colors 88) (background dark))
149     (:background "yellow1" :foreground "black"))
150    (((background dark)) (:background "yellow" :foreground "black"))
151    (((min-colors 88)) (:background "yellow1"))
152    (t (:background "yellow")))
153  "Default face for hi-lock mode."
154  :group 'hi-lock-faces)
155
156(defface hi-pink
157  '((((background dark)) (:background "pink" :foreground "black"))
158    (t (:background "pink")))
159  "Face for hi-lock mode."
160  :group 'hi-lock-faces)
161
162(defface hi-green
163  '((((min-colors 88) (background dark))
164     (:background "green1" :foreground "black"))
165    (((background dark)) (:background "green" :foreground "black"))
166    (((min-colors 88)) (:background "green1"))
167    (t (:background "green")))
168  "Face for hi-lock mode."
169  :group 'hi-lock-faces)
170
171(defface hi-blue
172  '((((background dark)) (:background "light blue" :foreground "black"))
173    (t (:background "light blue")))
174  "Face for hi-lock mode."
175  :group 'hi-lock-faces)
176
177(defface hi-black-b
178  '((t (:weight bold)))
179  "Face for hi-lock mode."
180  :group 'hi-lock-faces)
181
182(defface hi-blue-b
183  '((((min-colors 88)) (:weight bold :foreground "blue1"))
184    (t (:weight bold :foreground "blue")))
185  "Face for hi-lock mode."
186  :group 'hi-lock-faces)
187
188(defface hi-green-b
189  '((((min-colors 88)) (:weight bold :foreground "green1"))
190    (t (:weight bold :foreground "green")))
191  "Face for hi-lock mode."
192  :group 'hi-lock-faces)
193
194(defface hi-red-b
195  '((((min-colors 88)) (:weight bold :foreground "red1"))
196    (t (:weight bold :foreground "red")))
197  "Face for hi-lock mode."
198  :group 'hi-lock-faces)
199
200(defface hi-black-hb
201  '((t (:weight bold :height 1.67 :inherit variable-pitch)))
202  "Face for hi-lock mode."
203  :group 'hi-lock-faces)
204
205(defvar hi-lock-file-patterns nil
206  "Patterns found in file for hi-lock.  Should not be changed.")
207
208(defvar hi-lock-interactive-patterns nil
209  "Patterns provided to hi-lock by user.  Should not be changed.")
210
211(defvar hi-lock-face-history
212  (list "hi-yellow" "hi-pink" "hi-green" "hi-blue" "hi-black-b"
213        "hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb")
214      "History list of faces for hi-lock interactive functions.")
215
216;(dolist (f hi-lock-face-history) (unless (facep f) (error "%s not a face" f)))
217
218(defvar hi-lock-regexp-history nil
219  "History of regexps used for interactive fontification.")
220
221(defvar hi-lock-file-patterns-prefix "Hi-lock"
222  "Search target for finding hi-lock patterns at top of file.")
223
224(defvar hi-lock-archaic-interface-message-used nil
225  "True if user alerted that `global-hi-lock-mode' is now the global switch.
226Earlier versions of hi-lock used `hi-lock-mode' as the global switch;
227the message is issued if it appears that `hi-lock-mode' is used assuming
228that older functionality.  This variable avoids multiple reminders.")
229
230(defvar hi-lock-archaic-interface-deduce nil
231  "If non-nil, sometimes assume that `hi-lock-mode' means `global-hi-lock-mode'.
232Assumption is made if `hi-lock-mode' used in the *scratch* buffer while
233a library is being loaded.")
234
235(make-variable-buffer-local 'hi-lock-interactive-patterns)
236(put 'hi-lock-interactive-patterns 'permanent-local t)
237(make-variable-buffer-local 'hi-lock-regexp-history)
238(put 'hi-lock-regexp-history 'permanent-local t)
239(make-variable-buffer-local 'hi-lock-file-patterns)
240(put 'hi-lock-file-patterns 'permanent-local t)
241
242(defvar hi-lock-menu (make-sparse-keymap "Hi Lock")
243  "Menu for hi-lock mode.")
244
245(define-key-after hi-lock-menu [highlight-regexp]
246  '(menu-item "Highlight Regexp..." highlight-regexp
247              :help "Highlight text matching PATTERN (a regexp)."))
248
249(define-key-after hi-lock-menu [highlight-phrase]
250  '(menu-item "Highlight Phrase..." highlight-phrase
251              :help "Highlight text matching PATTERN (a regexp processed to match phrases)."))
252
253(define-key-after hi-lock-menu [highlight-lines-matching-regexp]
254  '(menu-item "Highlight Lines..." highlight-lines-matching-regexp
255              :help "Highlight lines containing match of PATTERN (a regexp).."))
256
257(define-key-after hi-lock-menu [unhighlight-regexp]
258  '(menu-item "Remove Highlighting..." unhighlight-regexp
259              :help "Remove previously entered highlighting pattern."
260              :enable hi-lock-interactive-patterns))
261
262(define-key-after hi-lock-menu [hi-lock-write-interactive-patterns]
263  '(menu-item "Patterns to Buffer" hi-lock-write-interactive-patterns
264              :help "Insert interactively added REGEXPs into buffer at point."
265              :enable hi-lock-interactive-patterns))
266
267(define-key-after hi-lock-menu [hi-lock-find-patterns]
268  '(menu-item "Patterns from Buffer" hi-lock-find-patterns
269              :help "Use patterns (if any) near top of buffer."))
270
271(defvar hi-lock-map (make-sparse-keymap "Hi Lock")
272  "Key map for hi-lock.")
273
274(define-key hi-lock-map "\C-xwi" 'hi-lock-find-patterns)
275(define-key hi-lock-map "\C-xwl" 'highlight-lines-matching-regexp)
276(define-key hi-lock-map "\C-xwp" 'highlight-phrase)
277(define-key hi-lock-map "\C-xwh" 'highlight-regexp)
278(define-key hi-lock-map "\C-xwr" 'unhighlight-regexp)
279(define-key hi-lock-map "\C-xwb" 'hi-lock-write-interactive-patterns)
280
281;; Visible Functions
282
283;;;###autoload
284(define-minor-mode hi-lock-mode
285  "Toggle minor mode for interactively adding font-lock highlighting patterns.
286
287If ARG positive, turn hi-lock on.  Issuing a hi-lock command will also
288turn hi-lock on.  To turn hi-lock on in all buffers use
289`global-hi-lock-mode' or in your .emacs file (global-hi-lock-mode 1).
290When hi-lock is turned on, a \"Regexp Highlighting\" submenu is added
291to the \"Edit\" menu.  The commands in the submenu, which can be
292called interactively, are:
293
294\\[highlight-regexp] REGEXP FACE
295  Highlight matches of pattern REGEXP in current buffer with FACE.
296
297\\[highlight-phrase] PHRASE FACE
298  Highlight matches of phrase PHRASE in current buffer with FACE.
299  (PHRASE can be any REGEXP, but spaces will be replaced by matches
300  to whitespace and initial lower-case letters will become case insensitive.)
301
302\\[highlight-lines-matching-regexp] REGEXP FACE
303  Highlight lines containing matches of REGEXP in current buffer with FACE.
304
305\\[unhighlight-regexp] REGEXP
306  Remove highlighting on matches of REGEXP in current buffer.
307
308\\[hi-lock-write-interactive-patterns]
309  Write active REGEXPs into buffer as comments (if possible).  They may
310  be read the next time file is loaded or when the \\[hi-lock-find-patterns] command
311  is issued.  The inserted regexps are in the form of font lock keywords.
312  (See `font-lock-keywords'.)  They may be edited and re-loaded with \\[hi-lock-find-patterns],
313  any valid `font-lock-keywords' form is acceptable. When a file is
314  loaded the patterns are read if `hi-lock-file-patterns-policy is
315  'ask and the user responds y to the prompt, or if
316  `hi-lock-file-patterns-policy' is bound to a function and that
317  function returns t.
318
319\\[hi-lock-find-patterns]
320  Re-read patterns stored in buffer (in the format produced by \\[hi-lock-write-interactive-patterns]).
321
322When hi-lock is started and if the mode is not excluded or patterns
323rejected, the beginning of the buffer is searched for lines of the
324form:
325  Hi-lock: FOO
326where FOO is a list of patterns.  These are added to the font lock
327keywords already present.  The patterns must start before position
328\(number of characters into buffer) `hi-lock-file-patterns-range'.
329Patterns will be read until
330 Hi-lock: end
331is found.  A mode is excluded if it's in the list `hi-lock-exclude-modes'."
332  :group 'hi-lock
333  :lighter (:eval (if (or hi-lock-interactive-patterns
334			  hi-lock-file-patterns)
335		      " Hi" ""))
336  :global nil
337  :keymap hi-lock-map
338  (when (and (equal (buffer-name) "*scratch*")
339             load-in-progress
340             (not (interactive-p))
341             (not hi-lock-archaic-interface-message-used))
342    (setq hi-lock-archaic-interface-message-used t)
343    (if hi-lock-archaic-interface-deduce
344        (global-hi-lock-mode hi-lock-mode)
345      (warn
346       "Possible archaic use of (hi-lock-mode).
347Use (global-hi-lock-mode 1) in .emacs to enable hi-lock for all buffers,
348use (hi-lock-mode 1) for individual buffers.  For compatibility with Emacs
349versions before 22 use the following in your .emacs file:
350
351        (if (functionp 'global-hi-lock-mode)
352            (global-hi-lock-mode 1)
353          (hi-lock-mode 1))
354")))
355  (if hi-lock-mode
356      ;; Turned on.
357      (progn
358	(unless font-lock-mode (font-lock-mode 1))
359	(define-key-after menu-bar-edit-menu [hi-lock]
360	  (cons "Regexp Highlighting" hi-lock-menu))
361	(hi-lock-find-patterns)
362	(add-hook 'font-lock-mode-hook 'hi-lock-font-lock-hook nil t))
363    ;; Turned off.
364    (when (or hi-lock-interactive-patterns
365	      hi-lock-file-patterns)
366      (when hi-lock-interactive-patterns
367	(font-lock-remove-keywords nil hi-lock-interactive-patterns)
368	(setq hi-lock-interactive-patterns nil))
369      (when hi-lock-file-patterns
370	(font-lock-remove-keywords nil hi-lock-file-patterns)
371	(setq hi-lock-file-patterns nil))
372      (remove-overlays nil nil 'hi-lock-overlay t)
373      (when font-lock-fontified (font-lock-fontify-buffer)))
374    (define-key-after menu-bar-edit-menu [hi-lock] nil)
375    (remove-hook 'font-lock-mode-hook 'hi-lock-font-lock-hook t)))
376
377;;;###autoload
378(define-globalized-minor-mode global-hi-lock-mode
379  hi-lock-mode turn-on-hi-lock-if-enabled
380  :group 'hi-lock)
381
382(defun turn-on-hi-lock-if-enabled ()
383  (setq hi-lock-archaic-interface-message-used t)
384  (unless (memq major-mode hi-lock-exclude-modes)
385    (hi-lock-mode 1)))
386
387;;;###autoload
388(defalias 'highlight-lines-matching-regexp 'hi-lock-line-face-buffer)
389;;;###autoload
390(defun hi-lock-line-face-buffer (regexp &optional face)
391  "Set face of all lines containing a match of REGEXP to FACE.
392
393Interactively, prompt for REGEXP then FACE.  Buffer-local history
394list maintained for regexps, global history maintained for faces.
395\\<minibuffer-local-map>Use \\[next-history-element] and \\[previous-history-element] to retrieve next or previous history item.
396\(See info node `Minibuffer History'.)"
397  (interactive
398   (list
399    (hi-lock-regexp-okay
400     (read-from-minibuffer "Regexp to highlight line: "
401                           (cons (or (car hi-lock-regexp-history) "") 1 )
402                           nil nil 'hi-lock-regexp-history))
403    (hi-lock-read-face-name)))
404  (or (facep face) (setq face 'hi-yellow))
405  (unless hi-lock-mode (hi-lock-mode 1))
406  (hi-lock-set-pattern
407   ;; The \\(?:...\\) grouping construct ensures that a leading ^, +, * or ?
408   ;; or a trailing $ in REGEXP will be interpreted correctly.
409   (concat "^.*\\(?:" regexp "\\).*$") face))
410
411
412;;;###autoload
413(defalias 'highlight-regexp 'hi-lock-face-buffer)
414;;;###autoload
415(defun hi-lock-face-buffer (regexp &optional face)
416  "Set face of each match of REGEXP to FACE.
417
418Interactively, prompt for REGEXP then FACE.  Buffer-local history
419list maintained for regexps, global history maintained for faces.
420\\<minibuffer-local-map>Use \\[next-history-element] and \\[previous-history-element] to retrieve next or previous history item.
421\(See info node `Minibuffer History'.)"
422  (interactive
423   (list
424    (hi-lock-regexp-okay
425     (read-from-minibuffer "Regexp to highlight: "
426                           (cons (or (car hi-lock-regexp-history) "") 1 )
427                           nil nil 'hi-lock-regexp-history))
428    (hi-lock-read-face-name)))
429  (or (facep face) (setq face 'hi-yellow))
430  (unless hi-lock-mode (hi-lock-mode 1))
431  (hi-lock-set-pattern regexp face))
432
433;;;###autoload
434(defalias 'highlight-phrase 'hi-lock-face-phrase-buffer)
435;;;###autoload
436(defun hi-lock-face-phrase-buffer (regexp &optional face)
437  "Set face of each match of phrase REGEXP to FACE.
438
439Whitespace in REGEXP converted to arbitrary whitespace and initial
440lower-case letters made case insensitive."
441  (interactive
442   (list
443    (hi-lock-regexp-okay
444     (hi-lock-process-phrase
445      (read-from-minibuffer "Phrase to highlight: "
446                            (cons (or (car hi-lock-regexp-history) "") 1 )
447                            nil nil 'hi-lock-regexp-history)))
448    (hi-lock-read-face-name)))
449  (or (facep face) (setq face 'hi-yellow))
450  (unless hi-lock-mode (hi-lock-mode 1))
451  (hi-lock-set-pattern regexp face))
452
453;;;###autoload
454(defalias 'unhighlight-regexp 'hi-lock-unface-buffer)
455;;;###autoload
456(defun hi-lock-unface-buffer (regexp)
457  "Remove highlighting of each match to REGEXP set by hi-lock.
458
459Interactively, prompt for REGEXP.  Buffer-local history of inserted
460regexp's maintained.  Will accept only regexps inserted by hi-lock
461interactive functions.  \(See `hi-lock-interactive-patterns'.\)
462\\<minibuffer-local-must-match-map>Use \\[minibuffer-complete] to complete a partially typed regexp.
463\(See info node `Minibuffer History'.\)"
464  (interactive
465   (if (and (display-popup-menus-p) (vectorp (this-command-keys)))
466       (catch 'snafu
467	 (or
468	  (x-popup-menu
469	   t
470	   (cons
471	    `keymap
472	    (cons "Select Pattern to Unhighlight"
473		  (mapcar (lambda (pattern)
474			    (list (car pattern)
475				  (format
476				   "%s (%s)" (car pattern)
477				   (symbol-name
478				    (car
479				     (cdr (car (cdr (car (cdr pattern))))))))
480				  (cons nil nil)
481				  (car pattern)))
482			  hi-lock-interactive-patterns))))
483	  ;; If the user clicks outside the menu, meaning that they
484	  ;; change their mind, x-popup-menu returns nil, and
485	  ;; interactive signals a wrong number of arguments error.
486	  ;; To prevent that, we return an empty string, which will
487	  ;; effectively disable the rest of the function.
488	  (throw 'snafu '(""))))
489     (let ((history-list (mapcar (lambda (p) (car p))
490                                 hi-lock-interactive-patterns)))
491       (unless hi-lock-interactive-patterns
492         (error "No highlighting to remove"))
493       (list
494        (completing-read "Regexp to unhighlight: "
495                         hi-lock-interactive-patterns nil t
496                         (car (car hi-lock-interactive-patterns))
497                         (cons 'history-list 1))))))
498  (let ((keyword (assoc regexp hi-lock-interactive-patterns)))
499    (when keyword
500      (font-lock-remove-keywords nil (list keyword))
501      (setq hi-lock-interactive-patterns
502            (delq keyword hi-lock-interactive-patterns))
503      (remove-overlays
504       nil nil 'hi-lock-overlay-regexp (hi-lock-string-serialize regexp))
505      (when font-lock-fontified (font-lock-fontify-buffer)))))
506
507;;;###autoload
508(defun hi-lock-write-interactive-patterns ()
509  "Write interactively added patterns, if any, into buffer at point.
510
511Interactively added patterns are those normally specified using
512`highlight-regexp' and `highlight-lines-matching-regexp'; they can
513be found in variable `hi-lock-interactive-patterns'."
514  (interactive)
515  (if (null hi-lock-interactive-patterns)
516      (error "There are no interactive patterns"))
517  (let ((beg (point)))
518    (mapcar
519     (lambda (pattern)
520       (insert (format "%s: (%s)\n"
521		       hi-lock-file-patterns-prefix
522		       (prin1-to-string pattern))))
523     hi-lock-interactive-patterns)
524    (comment-region beg (point)))
525  (when (> (point) hi-lock-file-patterns-range)
526    (warn "Inserted keywords not close enough to top of file")))
527
528;; Implementation Functions
529
530(defun hi-lock-process-phrase (phrase)
531  "Convert regexp PHRASE to a regexp that matches phrases.
532
533Blanks in PHRASE replaced by regexp that matches arbitrary whitespace
534and initial lower-case letters made case insensitive."
535  (let ((mod-phrase nil))
536    (setq mod-phrase
537          (replace-regexp-in-string
538           "\\<[a-z]" (lambda (m) (format "[%s%s]" (upcase m) m)) phrase))
539    (setq mod-phrase
540          (replace-regexp-in-string
541           "\\s-+" "[ \t\n]+" mod-phrase nil t))))
542
543(defun hi-lock-regexp-okay (regexp)
544  "Return REGEXP if it appears suitable for a font-lock pattern.
545
546Otherwise signal an error.  A pattern that matches the null string is
547not suitable."
548  (if (string-match regexp "")
549      (error "Regexp cannot match an empty string")
550    regexp))
551
552(defun hi-lock-read-face-name ()
553  "Read face name from minibuffer with completion and history."
554  (intern (completing-read
555           "Highlight using face: "
556           obarray 'facep t
557           (cons (car hi-lock-face-history)
558                 (let ((prefix
559                        (try-completion
560                         (substring (car hi-lock-face-history) 0 1)
561                         (mapcar (lambda (f) (cons f f))
562                                 hi-lock-face-history))))
563                   (if (and (stringp prefix)
564                            (not (equal prefix (car hi-lock-face-history))))
565                       (length prefix) 0)))
566           '(hi-lock-face-history . 0))))
567
568(defun hi-lock-set-pattern (regexp face)
569  "Highlight REGEXP with face FACE."
570  (let ((pattern (list regexp (list 0 (list 'quote face) t))))
571    (unless (member pattern hi-lock-interactive-patterns)
572      (font-lock-add-keywords nil (list pattern) t)
573      (push pattern hi-lock-interactive-patterns)
574      (if font-lock-fontified
575          (font-lock-fontify-buffer)
576        (let* ((serial (hi-lock-string-serialize regexp))
577               (range-min (- (point) (/ hi-lock-highlight-range 2)))
578               (range-max (+ (point) (/ hi-lock-highlight-range 2)))
579               (search-start
580                (max (point-min)
581                     (- range-min (max 0 (- range-max (point-max))))))
582               (search-end
583                (min (point-max)
584                     (+ range-max (max 0 (- (point-min) range-min))))))
585          (save-excursion
586            (goto-char search-start)
587            (while (re-search-forward regexp search-end t)
588              (let ((overlay (make-overlay (match-beginning 0) (match-end 0))))
589                (overlay-put overlay 'hi-lock-overlay t)
590                (overlay-put overlay 'hi-lock-overlay-regexp serial)
591                (overlay-put overlay 'face face))
592              (goto-char (match-end 0)))))))))
593
594(defun hi-lock-set-file-patterns (patterns)
595  "Replace file patterns list with PATTERNS and refontify."
596  (when (or hi-lock-file-patterns patterns)
597    (font-lock-remove-keywords nil hi-lock-file-patterns)
598    (setq hi-lock-file-patterns patterns)
599    (font-lock-add-keywords nil hi-lock-file-patterns t)
600    (font-lock-fontify-buffer)))
601
602(defun hi-lock-find-patterns ()
603  "Find patterns in current buffer for hi-lock."
604  (interactive)
605  (unless (memq major-mode hi-lock-exclude-modes)
606    (let ((all-patterns nil)
607          (target-regexp (concat "\\<" hi-lock-file-patterns-prefix ":")))
608      (save-excursion
609	(save-restriction
610	  (widen)
611	  (goto-char (point-min))
612	  (re-search-forward target-regexp
613			     (+ (point) hi-lock-file-patterns-range) t)
614	  (beginning-of-line)
615	  (while (and (re-search-forward target-regexp (+ (point) 100) t)
616		      (not (looking-at "\\s-*end")))
617            (condition-case nil
618                (setq all-patterns (append (read (current-buffer)) all-patterns))
619              (error (message "Invalid pattern list expression at %d"
620                              (line-number-at-pos)))))))
621      (when (and all-patterns
622                 hi-lock-mode
623                 (cond
624                  ((eq this-command 'hi-lock-find-patterns) t)
625                  ((functionp hi-lock-file-patterns-policy)
626                   (funcall hi-lock-file-patterns-policy all-patterns))
627                  ((eq hi-lock-file-patterns-policy 'ask)
628                   (y-or-n-p "Add patterns from this buffer to hi-lock? "))
629                  (t nil)))
630        (hi-lock-set-file-patterns all-patterns)
631        (if (interactive-p)
632            (message "Hi-lock added %d patterns." (length all-patterns)))))))
633
634(defun hi-lock-font-lock-hook ()
635  "Add hi-lock patterns to font-lock's."
636  (if font-lock-mode
637      (progn
638	(font-lock-add-keywords nil hi-lock-file-patterns t)
639	(font-lock-add-keywords nil hi-lock-interactive-patterns t))
640    (hi-lock-mode -1)))
641
642(defvar hi-lock-string-serialize-hash
643  (make-hash-table :test 'equal)
644  "Hash table used to assign unique numbers to strings.")
645
646(defvar hi-lock-string-serialize-serial 1
647  "Number assigned to last new string in call to `hi-lock-string-serialize'.
648A string is considered new if it had not previously been used in a call to
649`hi-lock-string-serialize'.")
650
651(defun hi-lock-string-serialize (string)
652  "Return unique serial number for STRING."
653  (interactive)
654  (let ((val (gethash string hi-lock-string-serialize-hash)))
655    (if val val
656      (puthash string
657               (setq hi-lock-string-serialize-serial
658                     (1+ hi-lock-string-serialize-serial))
659               hi-lock-string-serialize-hash)
660      hi-lock-string-serialize-serial)))
661
662(provide 'hi-lock)
663
664;; arch-tag: d2e8fd07-4cc9-4c6f-a200-1e729bc54066
665;;; hi-lock.el ends here
666