hi-lock.el 31.7 KB
Newer Older
1
;;; hi-lock.el --- minor mode for interactive automatic highlighting  -*- lexical-binding: t -*-
Gerd Moellmann's avatar
Gerd Moellmann committed
2

3
;; Copyright (C) 2000-2013 Free Software Foundation, Inc.
Gerd Moellmann's avatar
Gerd Moellmann committed
4

Glenn Morris's avatar
Glenn Morris committed
5
;; Author: David M. Koppelman <koppel@ece.lsu.edu>
Gerd Moellmann's avatar
Gerd Moellmann committed
6 7 8 9
;; Keywords: faces, minor-mode, matching, display

;; This file is part of GNU Emacs.

10
;; GNU Emacs is free software: you can redistribute it and/or modify
Gerd Moellmann's avatar
Gerd Moellmann committed
11
;; it under the terms of the GNU General Public License as published by
12 13
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Gerd Moellmann's avatar
Gerd Moellmann committed
14 15 16 17 18 19 20

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
21
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Gerd Moellmann's avatar
Gerd Moellmann committed
22

23
;;; Commentary:
24
;;
Gerd Moellmann's avatar
Gerd Moellmann committed
25 26 27 28 29 30 31 32
;;  With the hi-lock commands text matching interactively entered
;;  regexp's can be highlighted.  For example, `M-x highlight-regexp
;;  RET clearly RET RET' will highlight all occurrences of `clearly'
;;  using a yellow background face.  New occurrences of `clearly' will
;;  be highlighted as they are typed.  `M-x unhighlight-regexp RET'
;;  will remove the highlighting.  Any existing face can be used for
;;  highlighting and a set of appropriate faces is provided.  The
;;  regexps can be written into the current buffer in a form that will
33 34
;;  be recognized the next time the corresponding file is read (when
;;  file patterns is turned on).
Gerd Moellmann's avatar
Gerd Moellmann committed
35 36 37 38 39
;;
;;  Applications:
;;
;;    In program source code highlight a variable to quickly see all
;;    places it is modified or referenced:
40
;;    M-x highlight-regexp RET ground_contact_switches_closed RET RET
Gerd Moellmann's avatar
Gerd Moellmann committed
41 42 43
;;
;;    In a shell or other buffer that is showing lots of program
;;    output, highlight the parts of the output you're interested in:
44
;;    M-x highlight-regexp RET Total execution time [0-9]+ RET hi-blue-b RET
Gerd Moellmann's avatar
Gerd Moellmann committed
45 46
;;
;;    In buffers displaying tables, highlight the lines you're interested in:
47
;;    M-x highlight-lines-matching-regexp RET January 2000 RET hi-black-b RET
Gerd Moellmann's avatar
Gerd Moellmann committed
48 49 50
;;
;;    When writing text, highlight personal cliches.  This can be
;;    amusing.
51
;;    M-x highlight-phrase RET as can be seen RET RET
Gerd Moellmann's avatar
Gerd Moellmann committed
52
;;
53
;;  Setup:
Gerd Moellmann's avatar
Gerd Moellmann committed
54
;;
55
;;    Put the following code in your init file.  This turns on
56
;;    hi-lock mode and adds a "Regexp Highlighting" entry
Gerd Moellmann's avatar
Gerd Moellmann committed
57 58
;;    to the edit menu.
;;
59
;;    (global-hi-lock-mode 1)
60
;;
61
;;    To enable the use of patterns found in files (presumably placed
62
;;    there by hi-lock) include the following in your init file:
63 64 65 66
;;
;;    (setq hi-lock-file-patterns-policy 'ask)
;;
;;    If you get tired of being asked each time a file is loaded replace
67
;;    `ask' with a function that returns t if patterns should be read.
68
;;
Gerd Moellmann's avatar
Gerd Moellmann committed
69 70 71 72 73 74
;;    You might also want to bind the hi-lock commands to more
;;    finger-friendly sequences:

;;    (define-key hi-lock-map "\C-z\C-h" 'highlight-lines-matching-regexp)
;;    (define-key hi-lock-map "\C-zi" 'hi-lock-find-patterns)
;;    (define-key hi-lock-map "\C-zh" 'highlight-regexp)
75
;;    (define-key hi-lock-map "\C-zp" 'highlight-phrase)
Gerd Moellmann's avatar
Gerd Moellmann committed
76 77 78 79 80 81 82 83 84 85 86 87 88 89
;;    (define-key hi-lock-map "\C-zr" 'unhighlight-regexp)
;;    (define-key hi-lock-map "\C-zb" 'hi-lock-write-interactive-patterns))

;;    See the documentation for hi-lock-mode `C-h f hi-lock-mode' for
;;    additional instructions.

;; Sample file patterns:

; Hi-lock: (("^;;; .*" (0 (quote hi-black-hb) t)))
; Hi-lock: ( ("make-variable-buffer-\\(local\\)" (0 font-lock-keyword-face)(1 'italic append)))))
; Hi-lock: end

;;; Code:

90
(require 'font-lock)
Gerd Moellmann's avatar
Gerd Moellmann committed
91

92
(defgroup hi-lock nil
Gerd Moellmann's avatar
Gerd Moellmann committed
93
  "Interactively add and remove font-lock patterns for highlighting text."
94 95
  :link '(custom-manual "(emacs)Highlight Interactively")
  :group 'font-lock)
Gerd Moellmann's avatar
Gerd Moellmann committed
96 97 98

(defcustom hi-lock-file-patterns-range 10000
  "Limit of search in a buffer for hi-lock patterns.
99
When a file is visited and hi-lock mode is on, patterns starting
Gerd Moellmann's avatar
Gerd Moellmann committed
100 101 102
up to this limit are added to font-lock's patterns.  See documentation
of functions `hi-lock-mode' and `hi-lock-find-patterns'."
  :type 'integer
103
  :group 'hi-lock)
Gerd Moellmann's avatar
Gerd Moellmann committed
104

105 106 107 108 109 110 111 112 113 114
(defcustom hi-lock-highlight-range 200000
  "Size of area highlighted by hi-lock when font-lock not active.
Font-lock is not active in buffers that do their own highlighting,
such as the buffer created by `list-colors-display'.  In those buffers
hi-lock patterns will only be applied over a range of
`hi-lock-highlight-range' characters.  If font-lock is active then
highlighting will be applied throughout the buffer."
  :type 'integer
  :group 'hi-lock)

Gerd Moellmann's avatar
Gerd Moellmann committed
115 116 117 118 119
(defcustom hi-lock-exclude-modes
  '(rmail-mode mime/viewer-mode gnus-article-mode)
  "List of major modes in which hi-lock will not run.
For security reasons since font lock patterns can specify function
calls."
120
  :type '(repeat symbol)
121
  :group 'hi-lock)
Gerd Moellmann's avatar
Gerd Moellmann committed
122

123
(defcustom hi-lock-file-patterns-policy 'ask
124
  "Specify when hi-lock should use patterns found in file.
125
If `ask', prompt when patterns found in buffer; if bound to a function,
126
use patterns when function returns t (function is called with patterns
127
as first argument); if nil or `never' or anything else, don't use file
128 129 130 131 132 133 134 135 136
patterns."
  :type '(choice (const :tag "Do not use file patterns" never)
                 (const :tag "Ask about file patterns" ask)
                 (function :tag "Function to check file patterns"))
  :group 'hi-lock
  :version "22.1")

;; It can have a function value.
(put 'hi-lock-file-patterns-policy 'risky-local-variable t)
Gerd Moellmann's avatar
Gerd Moellmann committed
137

138 139 140
(defcustom hi-lock-auto-select-face nil
  "Non-nil if highlighting commands should not prompt for face names.
When non-nil, each hi-lock command will cycle through faces in
141
`hi-lock-face-defaults' without prompting."
142 143 144
  :type 'boolean
  :version "24.4")

Gerd Moellmann's avatar
Gerd Moellmann committed
145 146
(defgroup hi-lock-faces nil
  "Faces for hi-lock."
147 148
  :group 'hi-lock
  :group 'faces)
Gerd Moellmann's avatar
Gerd Moellmann committed
149 150

(defface hi-yellow
Kim F. Storm's avatar
Kim F. Storm committed
151
  '((((min-colors 88) (background dark))
152 153 154
     (:background "yellow1" :foreground "black"))
    (((background dark)) (:background "yellow" :foreground "black"))
    (((min-colors 88)) (:background "yellow1"))
155
    (t (:background "yellow")))
Gerd Moellmann's avatar
Gerd Moellmann committed
156 157 158 159
  "Default face for hi-lock mode."
  :group 'hi-lock-faces)

(defface hi-pink
160
  '((((background dark)) (:background "pink" :foreground "black"))
161
    (t (:background "pink")))
Gerd Moellmann's avatar
Gerd Moellmann committed
162 163 164 165
  "Face for hi-lock mode."
  :group 'hi-lock-faces)

(defface hi-green
Kim F. Storm's avatar
Kim F. Storm committed
166
  '((((min-colors 88) (background dark))
167
     (:background "light green" :foreground "black"))
168
    (((background dark)) (:background "green" :foreground "black"))
169
    (((min-colors 88)) (:background "light green"))
170
    (t (:background "green")))
Gerd Moellmann's avatar
Gerd Moellmann committed
171 172 173 174
  "Face for hi-lock mode."
  :group 'hi-lock-faces)

(defface hi-blue
175
  '((((background dark)) (:background "light blue" :foreground "black"))
176
    (t (:background "light blue")))
Gerd Moellmann's avatar
Gerd Moellmann committed
177 178 179 180 181 182 183 184 185
  "Face for hi-lock mode."
  :group 'hi-lock-faces)

(defface hi-black-b
  '((t (:weight bold)))
  "Face for hi-lock mode."
  :group 'hi-lock-faces)

(defface hi-blue-b
186 187
  '((((min-colors 88)) (:weight bold :foreground "blue1"))
    (t (:weight bold :foreground "blue")))
Gerd Moellmann's avatar
Gerd Moellmann committed
188 189 190 191
  "Face for hi-lock mode."
  :group 'hi-lock-faces)

(defface hi-green-b
192 193
  '((((min-colors 88)) (:weight bold :foreground "green1"))
    (t (:weight bold :foreground "green")))
Gerd Moellmann's avatar
Gerd Moellmann committed
194 195 196 197
  "Face for hi-lock mode."
  :group 'hi-lock-faces)

(defface hi-red-b
198 199
  '((((min-colors 88)) (:weight bold :foreground "red1"))
    (t (:weight bold :foreground "red")))
Gerd Moellmann's avatar
Gerd Moellmann committed
200 201 202 203
  "Face for hi-lock mode."
  :group 'hi-lock-faces)

(defface hi-black-hb
Miles Bader's avatar
Miles Bader committed
204
  '((t (:weight bold :height 1.67 :inherit variable-pitch)))
Gerd Moellmann's avatar
Gerd Moellmann committed
205 206 207
  "Face for hi-lock mode."
  :group 'hi-lock-faces)

208
(defvar-local hi-lock-file-patterns nil
Gerd Moellmann's avatar
Gerd Moellmann committed
209
  "Patterns found in file for hi-lock.  Should not be changed.")
210
(put 'hi-lock-file-patterns 'permanent-local t)
Gerd Moellmann's avatar
Gerd Moellmann committed
211

212
(defvar-local hi-lock-interactive-patterns nil
Gerd Moellmann's avatar
Gerd Moellmann committed
213
  "Patterns provided to hi-lock by user.  Should not be changed.")
214
(put 'hi-lock-interactive-patterns 'permanent-local t)
Gerd Moellmann's avatar
Gerd Moellmann committed
215

216 217
(define-obsolete-variable-alias 'hi-lock-face-history
                                'hi-lock-face-defaults "23.1")
218 219 220 221
(defvar hi-lock-face-defaults
  '("hi-yellow" "hi-pink" "hi-green" "hi-blue" "hi-black-b"
    "hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb")
  "Default faces for hi-lock interactive functions.")
Gerd Moellmann's avatar
Gerd Moellmann committed
222

223 224 225
(define-obsolete-variable-alias 'hi-lock-regexp-history
                                'regexp-history
                                "23.1")
Gerd Moellmann's avatar
Gerd Moellmann committed
226 227

(defvar hi-lock-file-patterns-prefix "Hi-lock"
228
  "Search target for finding hi-lock patterns at top of file.")
Gerd Moellmann's avatar
Gerd Moellmann committed
229

230
(defvar hi-lock-archaic-interface-message-used nil
231
  "True if user alerted that `global-hi-lock-mode' is now the global switch.
232
Earlier versions of hi-lock used `hi-lock-mode' as the global switch;
233
the message is issued if it appears that `hi-lock-mode' is used assuming
234 235 236
that older functionality.  This variable avoids multiple reminders.")

(defvar hi-lock-archaic-interface-deduce nil
237 238
  "If non-nil, sometimes assume that `hi-lock-mode' means `global-hi-lock-mode'.
Assumption is made if `hi-lock-mode' used in the *scratch* buffer while
239 240
a library is being loaded.")

241 242 243 244 245 246 247 248 249 250 251 252 253 254
(defvar hi-lock-menu
  (let ((map (make-sparse-keymap "Hi Lock")))
    (define-key-after map [highlight-regexp]
      '(menu-item "Highlight Regexp..." highlight-regexp
        :help "Highlight text matching PATTERN (a regexp)."))

    (define-key-after map [highlight-phrase]
      '(menu-item "Highlight Phrase..." highlight-phrase
        :help "Highlight text matching PATTERN (a regexp processed to match phrases)."))

    (define-key-after map [highlight-lines-matching-regexp]
      '(menu-item "Highlight Lines..." highlight-lines-matching-regexp
        :help "Highlight lines containing match of PATTERN (a regexp)."))

255 256 257 258
    (define-key-after map [highlight-symbol-at-point]
      '(menu-item "Highlight Symbol at Point" highlight-symbol-at-point
        :help "Highlight symbol found near point without prompting."))

259 260 261 262 263 264 265 266 267 268 269 270 271 272
    (define-key-after map [unhighlight-regexp]
      '(menu-item "Remove Highlighting..." unhighlight-regexp
        :help "Remove previously entered highlighting pattern."
        :enable hi-lock-interactive-patterns))

    (define-key-after map [hi-lock-write-interactive-patterns]
      '(menu-item "Patterns to Buffer" hi-lock-write-interactive-patterns
        :help "Insert interactively added REGEXPs into buffer at point."
        :enable hi-lock-interactive-patterns))

    (define-key-after map [hi-lock-find-patterns]
      '(menu-item "Patterns from Buffer" hi-lock-find-patterns
        :help "Use patterns (if any) near top of buffer."))
    map)
Gerd Moellmann's avatar
Gerd Moellmann committed
273 274
  "Menu for hi-lock mode.")

275 276 277 278 279 280
(defvar hi-lock-map
  (let ((map (make-sparse-keymap "Hi Lock")))
    (define-key map "\C-xwi" 'hi-lock-find-patterns)
    (define-key map "\C-xwl" 'highlight-lines-matching-regexp)
    (define-key map "\C-xwp" 'highlight-phrase)
    (define-key map "\C-xwh" 'highlight-regexp)
281
    (define-key map "\C-xw." 'highlight-symbol-at-point)
282 283 284
    (define-key map "\C-xwr" 'unhighlight-regexp)
    (define-key map "\C-xwb" 'hi-lock-write-interactive-patterns)
    map)
Gerd Moellmann's avatar
Gerd Moellmann committed
285 286
  "Key map for hi-lock.")

287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306
(defvar hi-lock-read-regexp-defaults-function
  'hi-lock-read-regexp-defaults
  "Function that provides default regexp(s) for highlighting commands.
This function should take no arguments and return one of nil, a
regexp or a list of regexps for use with highlighting commands -
`hi-lock-face-phrase-buffer', `hi-lock-line-face-buffer' and
`hi-lock-face-buffer'.  The return value of this function is used
as DEFAULTS param of `read-regexp' while executing the
highlighting command.  This function is called only during
interactive use.  

For example, to highlight at symbol at point use

    \(setq hi-lock-read-regexp-defaults-function 
	  'find-tag-default-as-regexp\)

If you need different defaults for different highlighting
operations, use `this-command' to identify the command under
execution.")

Gerd Moellmann's avatar
Gerd Moellmann committed
307 308 309
;; Visible Functions

;;;###autoload
310
(define-minor-mode hi-lock-mode
311 312 313 314 315
  "Toggle selective highlighting of patterns (Hi Lock mode).
With a prefix argument ARG, enable Hi Lock mode if ARG is
positive, and disable it otherwise.  If called from Lisp, enable
the mode if ARG is omitted or nil.

316 317 318 319 320 321 322 323 324 325 326 327 328
Hi Lock mode is automatically enabled when you invoke any of the
highlighting commands listed below, such as \\[highlight-regexp].
To enable Hi Lock mode in all buffers, use `global-hi-lock-mode'
or add (global-hi-lock-mode 1) to your init file.

In buffers where Font Lock mode is enabled, patterns are
highlighted using font lock.  In buffers where Font Lock mode is
disabled, patterns are applied using overlays; in this case, the
highlighting will not be updated as you type.

When Hi Lock mode is enabled, a \"Regexp Highlighting\" submenu
is added to the \"Edit\" menu.  The commands in the submenu,
which can be called interactively, are:
Gerd Moellmann's avatar
Gerd Moellmann committed
329 330 331 332

\\[highlight-regexp] REGEXP FACE
  Highlight matches of pattern REGEXP in current buffer with FACE.

333 334 335 336
\\[highlight-phrase] PHRASE FACE
  Highlight matches of phrase PHRASE in current buffer with FACE.
  (PHRASE can be any REGEXP, but spaces will be replaced by matches
  to whitespace and initial lower-case letters will become case insensitive.)
337

Gerd Moellmann's avatar
Gerd Moellmann committed
338 339 340
\\[highlight-lines-matching-regexp] REGEXP FACE
  Highlight lines containing matches of REGEXP in current buffer with FACE.

341 342 343 344
\\[highlight-symbol-at-point]
  Highlight the symbol found near point without prompting, using the next
  available face automatically.

Gerd Moellmann's avatar
Gerd Moellmann committed
345 346 347 348
\\[unhighlight-regexp] REGEXP
  Remove highlighting on matches of REGEXP in current buffer.

\\[hi-lock-write-interactive-patterns]
349
  Write active REGEXPs into buffer as comments (if possible).  They may
Gerd Moellmann's avatar
Gerd Moellmann committed
350 351
  be read the next time file is loaded or when the \\[hi-lock-find-patterns] command
  is issued.  The inserted regexps are in the form of font lock keywords.
352
  (See `font-lock-keywords'.)  They may be edited and re-loaded with \\[hi-lock-find-patterns],
353 354
  any valid `font-lock-keywords' form is acceptable.  When a file is
  loaded the patterns are read if `hi-lock-file-patterns-policy' is
355 356 357
  'ask and the user responds y to the prompt, or if
  `hi-lock-file-patterns-policy' is bound to a function and that
  function returns t.
Gerd Moellmann's avatar
Gerd Moellmann committed
358 359 360 361

\\[hi-lock-find-patterns]
  Re-read patterns stored in buffer (in the format produced by \\[hi-lock-write-interactive-patterns]).

362 363 364
When hi-lock is started and if the mode is not excluded or patterns
rejected, the beginning of the buffer is searched for lines of the
form:
Gerd Moellmann's avatar
Gerd Moellmann committed
365
  Hi-lock: FOO
366 367 368 369 370 371

where FOO is a list of patterns.  The patterns must start before
position \(number of characters into buffer)
`hi-lock-file-patterns-range'.  Patterns will be read until
Hi-lock: end is found.  A mode is excluded if it's in the list
`hi-lock-exclude-modes'."
372
  :group 'hi-lock
373 374 375
  :lighter (:eval (if (or hi-lock-interactive-patterns
			  hi-lock-file-patterns)
		      " Hi" ""))
376 377
  :global nil
  :keymap hi-lock-map
378 379
  (when (and (equal (buffer-name) "*scratch*")
             load-in-progress
380
             (not (called-interactively-p 'interactive))
381 382 383 384 385 386 387
             (not hi-lock-archaic-interface-message-used))
    (setq hi-lock-archaic-interface-message-used t)
    (if hi-lock-archaic-interface-deduce
        (global-hi-lock-mode hi-lock-mode)
      (warn
       "Possible archaic use of (hi-lock-mode).
Use (global-hi-lock-mode 1) in .emacs to enable hi-lock for all buffers,
388
use (hi-lock-mode 1) for individual buffers.  For compatibility with Emacs
389
versions before 22 use the following in your init file:
390 391 392 393 394 395

        (if (functionp 'global-hi-lock-mode)
            (global-hi-lock-mode 1)
          (hi-lock-mode 1))
")))
  (if hi-lock-mode
396 397 398 399 400
      ;; Turned on.
      (progn
	(define-key-after menu-bar-edit-menu [hi-lock]
	  (cons "Regexp Highlighting" hi-lock-menu))
	(hi-lock-find-patterns)
401 402 403
        (add-hook 'font-lock-mode-hook 'hi-lock-font-lock-hook nil t)
        ;; Remove regexps from font-lock-keywords (bug#13891).
	(add-hook 'change-major-mode-hook (lambda () (hi-lock-mode -1)) nil t))
Gerd Moellmann's avatar
Gerd Moellmann committed
404
    ;; Turned off.
405 406
    (when (or hi-lock-interactive-patterns
	      hi-lock-file-patterns)
407
      (when hi-lock-interactive-patterns
408 409 410 411 412
	(font-lock-remove-keywords nil hi-lock-interactive-patterns)
	(setq hi-lock-interactive-patterns nil))
      (when hi-lock-file-patterns
	(font-lock-remove-keywords nil hi-lock-file-patterns)
	(setq hi-lock-file-patterns nil))
413 414
      (remove-overlays nil nil 'hi-lock-overlay t)
      (when font-lock-fontified (font-lock-fontify-buffer)))
415 416
    (define-key-after menu-bar-edit-menu [hi-lock] nil)
    (remove-hook 'font-lock-mode-hook 'hi-lock-font-lock-hook t)))
Gerd Moellmann's avatar
Gerd Moellmann committed
417

418
;;;###autoload
419
(define-globalized-minor-mode global-hi-lock-mode
420
  hi-lock-mode turn-on-hi-lock-if-enabled
Chong Yidong's avatar
Chong Yidong committed
421
  :group 'hi-lock)
422

423
(defun turn-on-hi-lock-if-enabled ()
424
  (setq hi-lock-archaic-interface-message-used t)
425
  (unless (memq major-mode hi-lock-exclude-modes)
426
    (hi-lock-mode 1)))
Gerd Moellmann's avatar
Gerd Moellmann committed
427 428 429 430 431

;;;###autoload
(defalias 'highlight-lines-matching-regexp 'hi-lock-line-face-buffer)
;;;###autoload
(defun hi-lock-line-face-buffer (regexp &optional face)
432
  "Set face of all lines containing a match of REGEXP to FACE.
433 434 435
Interactively, prompt for REGEXP then FACE.  Use
`hi-lock-read-regexp-defaults-function' to retrieve default
value(s) of REGEXP.  Use the global history list for FACE.
Gerd Moellmann's avatar
Gerd Moellmann committed
436

437 438 439
Use Font lock mode, if enabled, to highlight REGEXP.  Otherwise,
use overlays for highlighting.  If overlays are used, the
highlighting will not update as you type."
Gerd Moellmann's avatar
Gerd Moellmann committed
440 441
  (interactive
   (list
442
    (hi-lock-regexp-okay
443 444
     (read-regexp "Regexp to highlight line"
		  (funcall hi-lock-read-regexp-defaults-function)))
Gerd Moellmann's avatar
Gerd Moellmann committed
445
    (hi-lock-read-face-name)))
446
  (or (facep face) (setq face 'hi-yellow))
447
  (unless hi-lock-mode (hi-lock-mode 1))
Gerd Moellmann's avatar
Gerd Moellmann committed
448
  (hi-lock-set-pattern
449 450
   ;; The \\(?:...\\) grouping construct ensures that a leading ^, +, * or ?
   ;; or a trailing $ in REGEXP will be interpreted correctly.
451
   (concat "^.*\\(?:" regexp "\\).*$") face))
Gerd Moellmann's avatar
Gerd Moellmann committed
452

453

Gerd Moellmann's avatar
Gerd Moellmann committed
454 455 456 457
;;;###autoload
(defalias 'highlight-regexp 'hi-lock-face-buffer)
;;;###autoload
(defun hi-lock-face-buffer (regexp &optional face)
458
  "Set face of each match of REGEXP to FACE.
459 460 461
Interactively, prompt for REGEXP then FACE.  Use
`hi-lock-read-regexp-defaults-function' to retrieve default
value(s) REGEXP.  Use the global history list for FACE.
Gerd Moellmann's avatar
Gerd Moellmann committed
462

463 464 465
Use Font lock mode, if enabled, to highlight REGEXP.  Otherwise,
use overlays for highlighting.  If overlays are used, the
highlighting will not update as you type."
Gerd Moellmann's avatar
Gerd Moellmann committed
466 467
  (interactive
   (list
468
    (hi-lock-regexp-okay
469 470
     (read-regexp "Regexp to highlight"
		  (funcall hi-lock-read-regexp-defaults-function)))
Gerd Moellmann's avatar
Gerd Moellmann committed
471
    (hi-lock-read-face-name)))
472
  (or (facep face) (setq face 'hi-yellow))
473
  (unless hi-lock-mode (hi-lock-mode 1))
474
  (hi-lock-set-pattern regexp face))
Gerd Moellmann's avatar
Gerd Moellmann committed
475

476 477 478 479 480
;;;###autoload
(defalias 'highlight-phrase 'hi-lock-face-phrase-buffer)
;;;###autoload
(defun hi-lock-face-phrase-buffer (regexp &optional face)
  "Set face of each match of phrase REGEXP to FACE.
481 482 483 484 485 486 487 488 489 490
Interactively, prompt for REGEXP then FACE.  Use
`hi-lock-read-regexp-defaults-function' to retrieve default
value(s) of REGEXP.  Use the global history list for FACE.  When
called interactively, replace whitespace in user provided regexp
with arbitrary whitespace and make initial lower-case letters
case-insensitive before highlighting with `hi-lock-set-pattern'.

Use Font lock mode, if enabled, to highlight REGEXP.  Otherwise,
use overlays for highlighting.  If overlays are used, the
highlighting will not update as you type."
491 492 493 494
  (interactive
   (list
    (hi-lock-regexp-okay
     (hi-lock-process-phrase
495 496
      (read-regexp "Phrase to highlight"
		   (funcall hi-lock-read-regexp-defaults-function))))
497
    (hi-lock-read-face-name)))
498
  (or (facep face) (setq face 'hi-yellow))
499
  (unless hi-lock-mode (hi-lock-mode 1))
500
  (hi-lock-set-pattern regexp face))
501

502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522
;;;###autoload
(defalias 'highlight-symbol-at-point 'hi-lock-face-symbol-at-point)
;;;###autoload
(defun hi-lock-face-symbol-at-point ()
  "Set face of each match of the symbol at point.
Use `find-tag-default-as-regexp' to retrieve the symbol at point.
Use non-nil `hi-lock-auto-select-face' to retrieve the next face
from `hi-lock-face-defaults' automatically.

Use Font lock mode, if enabled, to highlight symbol at point.
Otherwise, use overlays for highlighting.  If overlays are used,
the highlighting will not update as you type."
  (interactive)
  (let* ((regexp (hi-lock-regexp-okay
		  (find-tag-default-as-regexp)))
	 (hi-lock-auto-select-face t)
	 (face (hi-lock-read-face-name)))
    (or (facep face) (setq face 'hi-yellow))
    (unless hi-lock-mode (hi-lock-mode 1))
    (hi-lock-set-pattern regexp face)))

523 524 525
(defun hi-lock-keyword->face (keyword)
  (cadr (cadr (cadr keyword))))    ; Keyword looks like (REGEXP (0 'FACE) ...).

526
(declare-function x-popup-menu "menu.c" (position menu))
527

528 529 530 531
(defun hi-lock--regexps-at-point ()
  (let ((regexps '()))
    ;; When using overlays, there is no ambiguity on the best
    ;; choice of regexp.
532 533
    (let ((regexp (get-char-property (point) 'hi-lock-overlay-regexp)))
      (when regexp (push regexp regexps)))
534
    ;; With font-locking on, check if the cursor is on a highlighted text.
535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561
    (let ((face-after (get-text-property (point) 'face))
          (face-before
           (unless (bobp) (get-text-property (1- (point)) 'face)))
          (faces (mapcar #'hi-lock-keyword->face
                         hi-lock-interactive-patterns)))
      (unless (memq face-before faces) (setq face-before nil))
      (unless (memq face-after faces) (setq face-after nil))
      (when (and face-before face-after (not (eq face-before face-after)))
        (setq face-before nil))
      (when (or face-after face-before)
        (let* ((hi-text
                (buffer-substring-no-properties
                 (if face-before
                     (or (previous-single-property-change (point) 'face)
                         (point-min))
                   (point))
                 (if face-after
                     (or (next-single-property-change (point) 'face)
                         (point-max))
                   (point)))))
          ;; Compute hi-lock patterns that match the
          ;; highlighted text at point.  Use this later in
          ;; during completing-read.
          (dolist (hi-lock-pattern hi-lock-interactive-patterns)
            (let ((regexp (car hi-lock-pattern)))
              (if (string-match regexp hi-text)
                  (push regexp regexps)))))))
562
    regexps))
563

564 565 566
(defvar-local hi-lock--unused-faces nil
  "List of faces that is not used and is available for highlighting new text.
Face names from this list come from `hi-lock-face-defaults'.")
567

Gerd Moellmann's avatar
Gerd Moellmann committed
568 569 570 571
;;;###autoload
(defalias 'unhighlight-regexp 'hi-lock-unface-buffer)
;;;###autoload
(defun hi-lock-unface-buffer (regexp)
572
  "Remove highlighting of each match to REGEXP set by hi-lock.
573
Interactively, prompt for REGEXP, accepting only regexps
574 575 576
previously inserted by hi-lock interactive functions.
If REGEXP is t (or if \\[universal-argument] was specified interactively),
then remove all hi-lock highlighting."
Gerd Moellmann's avatar
Gerd Moellmann committed
577
  (interactive
578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593
   (cond
    (current-prefix-arg (list t))
    ((and (display-popup-menus-p)
          (listp last-nonmenu-event)
          use-dialog-box)
     (catch 'snafu
       (or
        (x-popup-menu
         t
         (cons
          `keymap
          (cons "Select Pattern to Unhighlight"
                (mapcar (lambda (pattern)
                          (list (car pattern)
                                (format
                                 "%s (%s)" (car pattern)
594
                                 (hi-lock-keyword->face pattern))
595 596 597 598 599 600 601 602 603 604 605 606 607 608
                                (cons nil nil)
                                (car pattern)))
                        hi-lock-interactive-patterns))))
        ;; If the user clicks outside the menu, meaning that they
        ;; change their mind, x-popup-menu returns nil, and
        ;; interactive signals a wrong number of arguments error.
        ;; To prevent that, we return an empty string, which will
        ;; effectively disable the rest of the function.
        (throw 'snafu '("")))))
    (t
     ;; Un-highlighting triggered via keyboard action.
     (unless hi-lock-interactive-patterns
       (error "No highlighting to remove"))
     ;; Infer the regexp to un-highlight based on cursor position.
609 610
     (let* ((defaults (or (hi-lock--regexps-at-point)
                          (mapcar #'car hi-lock-interactive-patterns))))
Gerd Moellmann's avatar
Gerd Moellmann committed
611
       (list
612 613 614 615 616 617 618 619
        (completing-read (if (null defaults)
                             "Regexp to unhighlight: "
                           (format "Regexp to unhighlight (default %s): "
                                   (car defaults)))
                         hi-lock-interactive-patterns
			 nil t nil nil defaults))))))
  (dolist (keyword (if (eq regexp t) hi-lock-interactive-patterns
                     (list (assoc regexp hi-lock-interactive-patterns))))
Gerd Moellmann's avatar
Gerd Moellmann committed
620
    (when keyword
621
      (let ((face (hi-lock-keyword->face keyword)))
622
        ;; Make `face' the next one to use by default.
623 624
        (when (symbolp face)          ;Don't add it if it's a list (bug#13297).
          (add-to-list 'hi-lock--unused-faces (face-name face))))
Gerd Moellmann's avatar
Gerd Moellmann committed
625 626 627
      (font-lock-remove-keywords nil (list keyword))
      (setq hi-lock-interactive-patterns
            (delq keyword hi-lock-interactive-patterns))
628
      (remove-overlays
629
       nil nil 'hi-lock-overlay-regexp (hi-lock--hashcons (car keyword)))
630
      (when font-lock-fontified (font-lock-fontify-buffer)))))
Gerd Moellmann's avatar
Gerd Moellmann committed
631 632 633 634 635 636 637 638 639

;;;###autoload
(defun hi-lock-write-interactive-patterns ()
  "Write interactively added patterns, if any, into buffer at point.

Interactively added patterns are those normally specified using
`highlight-regexp' and `highlight-lines-matching-regexp'; they can
be found in variable `hi-lock-interactive-patterns'."
  (interactive)
640 641 642
  (if (null hi-lock-interactive-patterns)
      (error "There are no interactive patterns"))
  (let ((beg (point)))
643
    (mapc
Gerd Moellmann's avatar
Gerd Moellmann committed
644
     (lambda (pattern)
645 646 647
       (insert (format "%s: (%s)\n"
		       hi-lock-file-patterns-prefix
		       (prin1-to-string pattern))))
648 649 650 651
     hi-lock-interactive-patterns)
    (comment-region beg (point)))
  (when (> (point) hi-lock-file-patterns-range)
    (warn "Inserted keywords not close enough to top of file")))
Gerd Moellmann's avatar
Gerd Moellmann committed
652 653 654

;; Implementation Functions

655 656 657 658 659 660
(defun hi-lock-process-phrase (phrase)
  "Convert regexp PHRASE to a regexp that matches phrases.

Blanks in PHRASE replaced by regexp that matches arbitrary whitespace
and initial lower-case letters made case insensitive."
  (let ((mod-phrase nil))
661
    ;; FIXME fragile; better to just bind case-fold-search?  (Bug#7161)
662 663
    (setq mod-phrase
          (replace-regexp-in-string
664 665 666 667 668
           "\\(^\\|\\s-\\)\\([a-z]\\)"
           (lambda (m) (format "%s[%s%s]"
                               (match-string 1 m)
                               (upcase (match-string 2 m))
                               (match-string 2 m))) phrase))
669
    ;; FIXME fragile; better to use search-spaces-regexp?
670 671 672 673
    (setq mod-phrase
          (replace-regexp-in-string
           "\\s-+" "[ \t\n]+" mod-phrase nil t))))

Gerd Moellmann's avatar
Gerd Moellmann committed
674 675 676 677 678 679 680 681 682
(defun hi-lock-regexp-okay (regexp)
  "Return REGEXP if it appears suitable for a font-lock pattern.

Otherwise signal an error.  A pattern that matches the null string is
not suitable."
  (if (string-match regexp "")
      (error "Regexp cannot match an empty string")
    regexp))

683 684 685 686 687
(defun hi-lock-read-regexp-defaults ()
  "Return the latest regexp from `regexp-history'.
See `hi-lock-read-regexp-defaults-function' for details."
  (car regexp-history))

Gerd Moellmann's avatar
Gerd Moellmann committed
688
(defun hi-lock-read-face-name ()
689
  "Return face for interactive highlighting.
690 691
When `hi-lock-auto-select-face' is non-nil, just return the next face.
Otherwise, read face name from minibuffer with completion and history."
692 693 694 695 696 697 698 699 700 701
  (unless hi-lock-interactive-patterns
    (setq hi-lock--unused-faces hi-lock-face-defaults))
  (let* ((last-used-face
	  (when hi-lock-interactive-patterns
	    (face-name (hi-lock-keyword->face
                        (car hi-lock-interactive-patterns)))))
	 (defaults (append hi-lock--unused-faces
			   (cdr (member last-used-face hi-lock-face-defaults))
			   hi-lock-face-defaults))
	 face)
702
          (if (and hi-lock-auto-select-face (not current-prefix-arg))
703 704 705 706 707 708 709 710 711 712
	(setq face (or (pop hi-lock--unused-faces) (car defaults)))
      (setq face (completing-read
		  (format "Highlight using face (default %s): "
			  (car defaults))
		  obarray 'facep t nil 'face-name-history defaults))
      ;; Update list of un-used faces.
      (setq hi-lock--unused-faces (remove face hi-lock--unused-faces))
      ;; Grow the list of defaults.
      (add-to-list 'hi-lock-face-defaults face t))
    (intern face)))
Gerd Moellmann's avatar
Gerd Moellmann committed
713

714 715
(defun hi-lock-set-pattern (regexp face)
  "Highlight REGEXP with face FACE."
716 717
  ;; Hashcons the regexp, so it can be passed to remove-overlays later.
  (setq regexp (hi-lock--hashcons regexp))
718
  (let ((pattern (list regexp (list 0 (list 'quote face) 'prepend))))
719 720
    ;; Refuse to highlight a text that is already highlighted.
    (unless (assoc regexp hi-lock-interactive-patterns)
721
      (push pattern hi-lock-interactive-patterns)
722
      (if (and font-lock-mode (font-lock-specified-p major-mode))
723 724 725
	  (progn
	    (font-lock-add-keywords nil (list pattern) t)
	    (font-lock-fontify-buffer))
726
        (let* ((range-min (- (point) (/ hi-lock-highlight-range 2)))
727 728 729 730 731 732 733 734 735 736 737 738
               (range-max (+ (point) (/ hi-lock-highlight-range 2)))
               (search-start
                (max (point-min)
                     (- range-min (max 0 (- range-max (point-max))))))
               (search-end
                (min (point-max)
                     (+ range-max (max 0 (- (point-min) range-min))))))
          (save-excursion
            (goto-char search-start)
            (while (re-search-forward regexp search-end t)
              (let ((overlay (make-overlay (match-beginning 0) (match-end 0))))
                (overlay-put overlay 'hi-lock-overlay t)
739
                (overlay-put overlay 'hi-lock-overlay-regexp regexp)
740 741
                (overlay-put overlay 'face face))
              (goto-char (match-end 0)))))))))
Gerd Moellmann's avatar
Gerd Moellmann committed
742 743 744

(defun hi-lock-set-file-patterns (patterns)
  "Replace file patterns list with PATTERNS and refontify."
745 746 747
  (when (or hi-lock-file-patterns patterns)
    (font-lock-remove-keywords nil hi-lock-file-patterns)
    (setq hi-lock-file-patterns patterns)
748
    (font-lock-add-keywords nil hi-lock-file-patterns t)
749
    (font-lock-fontify-buffer)))
Gerd Moellmann's avatar
Gerd Moellmann committed
750 751 752 753 754 755 756 757

(defun hi-lock-find-patterns ()
  "Find patterns in current buffer for hi-lock."
  (interactive)
  (unless (memq major-mode hi-lock-exclude-modes)
    (let ((all-patterns nil)
          (target-regexp (concat "\\<" hi-lock-file-patterns-prefix ":")))
      (save-excursion
Stefan Monnier's avatar
Stefan Monnier committed
758 759 760 761 762 763 764 765
	(save-restriction
	  (widen)
	  (goto-char (point-min))
	  (re-search-forward target-regexp
			     (+ (point) hi-lock-file-patterns-range) t)
	  (beginning-of-line)
	  (while (and (re-search-forward target-regexp (+ (point) 100) t)
		      (not (looking-at "\\s-*end")))
766 767 768
            (condition-case nil
                (setq all-patterns (append (read (current-buffer)) all-patterns))
              (error (message "Invalid pattern list expression at %d"
769
                              (line-number-at-pos)))))))
770 771 772 773 774 775 776 777 778 779
      (when (and all-patterns
                 hi-lock-mode
                 (cond
                  ((eq this-command 'hi-lock-find-patterns) t)
                  ((functionp hi-lock-file-patterns-policy)
                   (funcall hi-lock-file-patterns-policy all-patterns))
                  ((eq hi-lock-file-patterns-policy 'ask)
                   (y-or-n-p "Add patterns from this buffer to hi-lock? "))
                  (t nil)))
        (hi-lock-set-file-patterns all-patterns)
780
        (if (called-interactively-p 'interactive)
781
            (message "Hi-lock added %d patterns." (length all-patterns)))))))
Gerd Moellmann's avatar
Gerd Moellmann committed
782 783

(defun hi-lock-font-lock-hook ()
784
  "Add hi-lock patterns to font-lock's."
785 786 787
  (when font-lock-fontified
    (font-lock-add-keywords nil hi-lock-file-patterns t)
    (font-lock-add-keywords nil hi-lock-interactive-patterns t)))
Gerd Moellmann's avatar
Gerd Moellmann committed
788

789 790 791
(defvar hi-lock--hashcons-hash
  (make-hash-table :test 'equal :weakness t)
  "Hash table used to hash cons regexps.")
792

793 794 795 796
(defun hi-lock--hashcons (string)
  "Return unique object equal to STRING."
  (or (gethash string hi-lock--hashcons-hash)
      (puthash string string hi-lock--hashcons-hash)))
797

798 799 800 801 802 803
(defun hi-lock-unload-function ()
  "Unload the Hi-Lock library."
  (global-hi-lock-mode -1)
  ;; continue standard unloading
  nil)

Gerd Moellmann's avatar
Gerd Moellmann committed
804 805 806
(provide 'hi-lock)

;;; hi-lock.el ends here