| 1 | ;;; hi-lock.el --- minor mode for interactive automatic highlighting -*- lexical-binding: t -*- |
| 2 | |
| 3 | ;; Copyright (C) 2000-2014 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: David M. Koppelman <koppel@ece.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 3 of the License, or |
| 13 | ;; (at your option) 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. If not, see <http://www.gnu.org/licenses/>. |
| 22 | |
| 23 | ;;; Commentary: |
| 24 | ;; |
| 25 | ;; With the hi-lock commands text matching interactively entered |
| 26 | ;; regexp's can be highlighted. For example, `M-x highlight-regexp |
| 27 | ;; RET clearly RET RET' will highlight all occurrences of `clearly' |
| 28 | ;; using a yellow background face. New occurrences of `clearly' will |
| 29 | ;; be highlighted as they are typed. `M-x unhighlight-regexp RET' |
| 30 | ;; will remove the highlighting. Any existing face can be used for |
| 31 | ;; highlighting and a set of appropriate faces is provided. The |
| 32 | ;; regexps can be written into the current buffer in a form that will |
| 33 | ;; be recognized the next time the corresponding file is read (when |
| 34 | ;; file patterns is turned on). |
| 35 | ;; |
| 36 | ;; Applications: |
| 37 | ;; |
| 38 | ;; In program source code highlight a variable to quickly see all |
| 39 | ;; places it is modified or referenced: |
| 40 | ;; M-x highlight-regexp RET ground_contact_switches_closed RET RET |
| 41 | ;; |
| 42 | ;; In a shell or other buffer that is showing lots of program |
| 43 | ;; 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 |
| 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 |
| 48 | ;; |
| 49 | ;; When writing text, highlight personal cliches. This can be |
| 50 | ;; amusing. |
| 51 | ;; M-x highlight-phrase RET as can be seen RET RET |
| 52 | ;; |
| 53 | ;; Setup: |
| 54 | ;; |
| 55 | ;; Put the following code in your init file. This turns on |
| 56 | ;; hi-lock mode and adds a "Regexp Highlighting" entry |
| 57 | ;; to the edit menu. |
| 58 | ;; |
| 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 | ;; (setq hi-lock-file-patterns-policy 'ask) |
| 65 | ;; |
| 66 | ;; 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 | ;; |
| 69 | ;; You might also want to bind the hi-lock commands to more |
| 70 | ;; finger-friendly sequences: |
| 71 | |
| 72 | ;; (define-key hi-lock-map "\C-z\C-h" 'highlight-lines-matching-regexp) |
| 73 | ;; (define-key hi-lock-map "\C-zi" 'hi-lock-find-patterns) |
| 74 | ;; (define-key hi-lock-map "\C-zh" 'highlight-regexp) |
| 75 | ;; (define-key hi-lock-map "\C-zp" 'highlight-phrase) |
| 76 | ;; (define-key hi-lock-map "\C-zr" 'unhighlight-regexp) |
| 77 | ;; (define-key hi-lock-map "\C-zb" 'hi-lock-write-interactive-patterns)) |
| 78 | |
| 79 | ;; See the documentation for hi-lock-mode `C-h f hi-lock-mode' for |
| 80 | ;; additional instructions. |
| 81 | |
| 82 | ;; Sample file patterns: |
| 83 | |
| 84 | ; Hi-lock: (("^;;; .*" (0 (quote hi-black-hb) t))) |
| 85 | ; Hi-lock: ( ("make-variable-buffer-\\(local\\)" (0 font-lock-keyword-face)(1 'italic append))))) |
| 86 | ; Hi-lock: end |
| 87 | |
| 88 | ;;; Code: |
| 89 | |
| 90 | (require 'font-lock) |
| 91 | |
| 92 | (defgroup hi-lock nil |
| 93 | "Interactively add and remove font-lock patterns for highlighting text." |
| 94 | :link '(custom-manual "(emacs)Highlight Interactively") |
| 95 | :group 'font-lock) |
| 96 | |
| 97 | (defcustom hi-lock-file-patterns-range 10000 |
| 98 | "Limit of search in a buffer for hi-lock patterns. |
| 99 | When a file is visited and hi-lock mode is on, patterns starting |
| 100 | up to this limit are added to font-lock's patterns. See documentation |
| 101 | of functions `hi-lock-mode' and `hi-lock-find-patterns'." |
| 102 | :type 'integer |
| 103 | :group 'hi-lock) |
| 104 | |
| 105 | (defcustom hi-lock-highlight-range 200000 |
| 106 | "Size of area highlighted by hi-lock when font-lock not active. |
| 107 | Font-lock is not active in buffers that do their own highlighting, |
| 108 | such as the buffer created by `list-colors-display'. In those buffers |
| 109 | hi-lock patterns will only be applied over a range of |
| 110 | `hi-lock-highlight-range' characters. If font-lock is active then |
| 111 | highlighting will be applied throughout the buffer." |
| 112 | :type 'integer |
| 113 | :group 'hi-lock) |
| 114 | |
| 115 | (defcustom hi-lock-exclude-modes |
| 116 | '(rmail-mode mime/viewer-mode gnus-article-mode) |
| 117 | "List of major modes in which hi-lock will not run. |
| 118 | For security reasons since font lock patterns can specify function |
| 119 | calls." |
| 120 | :type '(repeat symbol) |
| 121 | :group 'hi-lock) |
| 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 | patterns." |
| 129 | :type '(choice (const :tag "Do not use file patterns" never) |
| 130 | (const :tag "Ask about file patterns" ask) |
| 131 | (function :tag "Function to check file patterns")) |
| 132 | :group 'hi-lock |
| 133 | :version "22.1") |
| 134 | |
| 135 | ;; It can have a function value. |
| 136 | (put 'hi-lock-file-patterns-policy 'risky-local-variable t) |
| 137 | |
| 138 | (defcustom hi-lock-auto-select-face nil |
| 139 | "Non-nil means highlighting commands do not prompt for the face to use. |
| 140 | Instead, each hi-lock command will cycle through the faces in |
| 141 | `hi-lock-face-defaults'." |
| 142 | :type 'boolean |
| 143 | :version "24.4") |
| 144 | |
| 145 | (defgroup hi-lock-faces nil |
| 146 | "Faces for hi-lock." |
| 147 | :group 'hi-lock |
| 148 | :group 'faces) |
| 149 | |
| 150 | (defface hi-yellow |
| 151 | '((((min-colors 88) (background dark)) |
| 152 | (:background "yellow1" :foreground "black")) |
| 153 | (((background dark)) (:background "yellow" :foreground "black")) |
| 154 | (((min-colors 88)) (:background "yellow1")) |
| 155 | (t (:background "yellow"))) |
| 156 | "Default face for hi-lock mode." |
| 157 | :group 'hi-lock-faces) |
| 158 | |
| 159 | (defface hi-pink |
| 160 | '((((background dark)) (:background "pink" :foreground "black")) |
| 161 | (t (:background "pink"))) |
| 162 | "Face for hi-lock mode." |
| 163 | :group 'hi-lock-faces) |
| 164 | |
| 165 | (defface hi-green |
| 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"))) |
| 171 | "Face for hi-lock mode." |
| 172 | :group 'hi-lock-faces) |
| 173 | |
| 174 | (defface hi-blue |
| 175 | '((((background dark)) (:background "light blue" :foreground "black")) |
| 176 | (t (:background "light blue"))) |
| 177 | "Face for hi-lock mode." |
| 178 | :group 'hi-lock-faces) |
| 179 | |
| 180 | (defface hi-black-b |
| 181 | '((t (:weight bold))) |
| 182 | "Face for hi-lock mode." |
| 183 | :group 'hi-lock-faces) |
| 184 | |
| 185 | (defface hi-blue-b |
| 186 | '((((min-colors 88)) (:weight bold :foreground "blue1")) |
| 187 | (t (:weight bold :foreground "blue"))) |
| 188 | "Face for hi-lock mode." |
| 189 | :group 'hi-lock-faces) |
| 190 | |
| 191 | (defface hi-green-b |
| 192 | '((((min-colors 88)) (:weight bold :foreground "green1")) |
| 193 | (t (:weight bold :foreground "green"))) |
| 194 | "Face for hi-lock mode." |
| 195 | :group 'hi-lock-faces) |
| 196 | |
| 197 | (defface hi-red-b |
| 198 | '((((min-colors 88)) (:weight bold :foreground "red1")) |
| 199 | (t (:weight bold :foreground "red"))) |
| 200 | "Face for hi-lock mode." |
| 201 | :group 'hi-lock-faces) |
| 202 | |
| 203 | (defface hi-black-hb |
| 204 | '((t (:weight bold :height 1.67 :inherit variable-pitch))) |
| 205 | "Face for hi-lock mode." |
| 206 | :group 'hi-lock-faces) |
| 207 | |
| 208 | (defvar-local hi-lock-file-patterns nil |
| 209 | "Patterns found in file for hi-lock. Should not be changed.") |
| 210 | (put 'hi-lock-file-patterns 'permanent-local t) |
| 211 | |
| 212 | (defvar-local hi-lock-interactive-patterns nil |
| 213 | "Patterns provided to hi-lock by user. Should not be changed.") |
| 214 | (put 'hi-lock-interactive-patterns 'permanent-local t) |
| 215 | |
| 216 | (define-obsolete-variable-alias 'hi-lock-face-history |
| 217 | 'hi-lock-face-defaults "23.1") |
| 218 | (defvar hi-lock-face-defaults |
| 219 | '("hi-yellow" "hi-pink" "hi-green" "hi-blue" "hi-black-b" |
| 220 | "hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb") |
| 221 | "Default faces for hi-lock interactive functions.") |
| 222 | |
| 223 | (define-obsolete-variable-alias 'hi-lock-regexp-history |
| 224 | 'regexp-history |
| 225 | "23.1") |
| 226 | |
| 227 | (defvar hi-lock-file-patterns-prefix "Hi-lock" |
| 228 | "Search target for finding hi-lock patterns at top of file.") |
| 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 | that older functionality. This variable avoids multiple reminders.") |
| 235 | |
| 236 | (defvar hi-lock-archaic-interface-deduce nil |
| 237 | "If non-nil, sometimes assume that `hi-lock-mode' means `global-hi-lock-mode'. |
| 238 | Assumption is made if `hi-lock-mode' used in the *scratch* buffer while |
| 239 | a library is being loaded.") |
| 240 | |
| 241 | (defvar hi-lock-menu |
| 242 | (let ((map (make-sparse-keymap "Hi Lock"))) |
| 243 | (define-key-after map [highlight-regexp] |
| 244 | '(menu-item "Highlight Regexp..." highlight-regexp |
| 245 | :help "Highlight text matching PATTERN (a regexp).")) |
| 246 | |
| 247 | (define-key-after map [highlight-phrase] |
| 248 | '(menu-item "Highlight Phrase..." highlight-phrase |
| 249 | :help "Highlight text matching PATTERN (a regexp processed to match phrases).")) |
| 250 | |
| 251 | (define-key-after map [highlight-lines-matching-regexp] |
| 252 | '(menu-item "Highlight Lines..." highlight-lines-matching-regexp |
| 253 | :help "Highlight lines containing match of PATTERN (a regexp).")) |
| 254 | |
| 255 | (define-key-after map [highlight-symbol-at-point] |
| 256 | '(menu-item "Highlight Symbol at Point" highlight-symbol-at-point |
| 257 | :help "Highlight symbol found near point without prompting.")) |
| 258 | |
| 259 | (define-key-after map [unhighlight-regexp] |
| 260 | '(menu-item "Remove Highlighting..." unhighlight-regexp |
| 261 | :help "Remove previously entered highlighting pattern." |
| 262 | :enable hi-lock-interactive-patterns)) |
| 263 | |
| 264 | (define-key-after map [hi-lock-write-interactive-patterns] |
| 265 | '(menu-item "Patterns to Buffer" hi-lock-write-interactive-patterns |
| 266 | :help "Insert interactively added REGEXPs into buffer at point." |
| 267 | :enable hi-lock-interactive-patterns)) |
| 268 | |
| 269 | (define-key-after map [hi-lock-find-patterns] |
| 270 | '(menu-item "Patterns from Buffer" hi-lock-find-patterns |
| 271 | :help "Use patterns (if any) near top of buffer.")) |
| 272 | map) |
| 273 | "Menu for hi-lock mode.") |
| 274 | |
| 275 | (defvar hi-lock-map |
| 276 | (let ((map (make-sparse-keymap "Hi Lock"))) |
| 277 | (define-key map "\C-xwi" 'hi-lock-find-patterns) |
| 278 | (define-key map "\C-xwl" 'highlight-lines-matching-regexp) |
| 279 | (define-key map "\C-xwp" 'highlight-phrase) |
| 280 | (define-key map "\C-xwh" 'highlight-regexp) |
| 281 | (define-key map "\C-xw." 'highlight-symbol-at-point) |
| 282 | (define-key map "\C-xwr" 'unhighlight-regexp) |
| 283 | (define-key map "\C-xwb" 'hi-lock-write-interactive-patterns) |
| 284 | map) |
| 285 | "Key map for hi-lock.") |
| 286 | |
| 287 | ;; Visible Functions |
| 288 | |
| 289 | ;;;###autoload |
| 290 | (define-minor-mode hi-lock-mode |
| 291 | "Toggle selective highlighting of patterns (Hi Lock mode). |
| 292 | With a prefix argument ARG, enable Hi Lock mode if ARG is |
| 293 | positive, and disable it otherwise. If called from Lisp, enable |
| 294 | the mode if ARG is omitted or nil. |
| 295 | |
| 296 | Hi Lock mode is automatically enabled when you invoke any of the |
| 297 | highlighting commands listed below, such as \\[highlight-regexp]. |
| 298 | To enable Hi Lock mode in all buffers, use `global-hi-lock-mode' |
| 299 | or add (global-hi-lock-mode 1) to your init file. |
| 300 | |
| 301 | In buffers where Font Lock mode is enabled, patterns are |
| 302 | highlighted using font lock. In buffers where Font Lock mode is |
| 303 | disabled, patterns are applied using overlays; in this case, the |
| 304 | highlighting will not be updated as you type. |
| 305 | |
| 306 | When Hi Lock mode is enabled, a \"Regexp Highlighting\" submenu |
| 307 | is added to the \"Edit\" menu. The commands in the submenu, |
| 308 | which can be called interactively, are: |
| 309 | |
| 310 | \\[highlight-regexp] REGEXP FACE |
| 311 | Highlight matches of pattern REGEXP in current buffer with FACE. |
| 312 | |
| 313 | \\[highlight-phrase] PHRASE FACE |
| 314 | Highlight matches of phrase PHRASE in current buffer with FACE. |
| 315 | (PHRASE can be any REGEXP, but spaces will be replaced by matches |
| 316 | to whitespace and initial lower-case letters will become case insensitive.) |
| 317 | |
| 318 | \\[highlight-lines-matching-regexp] REGEXP FACE |
| 319 | Highlight lines containing matches of REGEXP in current buffer with FACE. |
| 320 | |
| 321 | \\[highlight-symbol-at-point] |
| 322 | Highlight the symbol found near point without prompting, using the next |
| 323 | available face automatically. |
| 324 | |
| 325 | \\[unhighlight-regexp] REGEXP |
| 326 | Remove highlighting on matches of REGEXP in current buffer. |
| 327 | |
| 328 | \\[hi-lock-write-interactive-patterns] |
| 329 | Write active REGEXPs into buffer as comments (if possible). They may |
| 330 | be read the next time file is loaded or when the \\[hi-lock-find-patterns] command |
| 331 | is issued. The inserted regexps are in the form of font lock keywords. |
| 332 | (See `font-lock-keywords'.) They may be edited and re-loaded with \\[hi-lock-find-patterns], |
| 333 | any valid `font-lock-keywords' form is acceptable. When a file is |
| 334 | loaded the patterns are read if `hi-lock-file-patterns-policy' is |
| 335 | 'ask and the user responds y to the prompt, or if |
| 336 | `hi-lock-file-patterns-policy' is bound to a function and that |
| 337 | function returns t. |
| 338 | |
| 339 | \\[hi-lock-find-patterns] |
| 340 | Re-read patterns stored in buffer (in the format produced by \\[hi-lock-write-interactive-patterns]). |
| 341 | |
| 342 | When hi-lock is started and if the mode is not excluded or patterns |
| 343 | rejected, the beginning of the buffer is searched for lines of the |
| 344 | form: |
| 345 | Hi-lock: FOO |
| 346 | |
| 347 | where FOO is a list of patterns. The patterns must start before |
| 348 | position \(number of characters into buffer) |
| 349 | `hi-lock-file-patterns-range'. Patterns will be read until |
| 350 | Hi-lock: end is found. A mode is excluded if it's in the list |
| 351 | `hi-lock-exclude-modes'." |
| 352 | :group 'hi-lock |
| 353 | :lighter (:eval (if (or hi-lock-interactive-patterns |
| 354 | hi-lock-file-patterns) |
| 355 | " Hi" "")) |
| 356 | :global nil |
| 357 | :keymap hi-lock-map |
| 358 | (when (and (equal (buffer-name) "*scratch*") |
| 359 | load-in-progress |
| 360 | (not (called-interactively-p 'interactive)) |
| 361 | (not hi-lock-archaic-interface-message-used)) |
| 362 | (setq hi-lock-archaic-interface-message-used t) |
| 363 | (if hi-lock-archaic-interface-deduce |
| 364 | (global-hi-lock-mode hi-lock-mode) |
| 365 | (warn |
| 366 | "Possible archaic use of (hi-lock-mode). |
| 367 | Use (global-hi-lock-mode 1) in .emacs to enable hi-lock for all buffers, |
| 368 | use (hi-lock-mode 1) for individual buffers. For compatibility with Emacs |
| 369 | versions before 22 use the following in your init file: |
| 370 | |
| 371 | (if (functionp 'global-hi-lock-mode) |
| 372 | (global-hi-lock-mode 1) |
| 373 | (hi-lock-mode 1)) |
| 374 | "))) |
| 375 | (if hi-lock-mode |
| 376 | ;; Turned on. |
| 377 | (progn |
| 378 | (define-key-after menu-bar-edit-menu [hi-lock] |
| 379 | (cons "Regexp Highlighting" hi-lock-menu)) |
| 380 | (hi-lock-find-patterns) |
| 381 | (add-hook 'font-lock-mode-hook 'hi-lock-font-lock-hook nil t) |
| 382 | ;; Remove regexps from font-lock-keywords (bug#13891). |
| 383 | (add-hook 'change-major-mode-hook (lambda () (hi-lock-mode -1)) nil t)) |
| 384 | ;; Turned off. |
| 385 | (when (or hi-lock-interactive-patterns |
| 386 | hi-lock-file-patterns) |
| 387 | (when hi-lock-interactive-patterns |
| 388 | (font-lock-remove-keywords nil hi-lock-interactive-patterns) |
| 389 | (setq hi-lock-interactive-patterns nil)) |
| 390 | (when hi-lock-file-patterns |
| 391 | (font-lock-remove-keywords nil hi-lock-file-patterns) |
| 392 | (setq hi-lock-file-patterns nil)) |
| 393 | (remove-overlays nil nil 'hi-lock-overlay t) |
| 394 | (font-lock-flush)) |
| 395 | (define-key-after menu-bar-edit-menu [hi-lock] nil) |
| 396 | (remove-hook 'font-lock-mode-hook 'hi-lock-font-lock-hook t))) |
| 397 | |
| 398 | ;;;###autoload |
| 399 | (define-globalized-minor-mode global-hi-lock-mode |
| 400 | hi-lock-mode turn-on-hi-lock-if-enabled |
| 401 | :group 'hi-lock) |
| 402 | |
| 403 | (defun turn-on-hi-lock-if-enabled () |
| 404 | (setq hi-lock-archaic-interface-message-used t) |
| 405 | (unless (memq major-mode hi-lock-exclude-modes) |
| 406 | (hi-lock-mode 1))) |
| 407 | |
| 408 | ;;;###autoload |
| 409 | (defalias 'highlight-lines-matching-regexp 'hi-lock-line-face-buffer) |
| 410 | ;;;###autoload |
| 411 | (defun hi-lock-line-face-buffer (regexp &optional face) |
| 412 | "Set face of all lines containing a match of REGEXP to FACE. |
| 413 | Interactively, prompt for REGEXP using `read-regexp', then FACE. |
| 414 | Use the global history list for FACE. |
| 415 | |
| 416 | Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, |
| 417 | use overlays for highlighting. If overlays are used, the |
| 418 | highlighting will not update as you type." |
| 419 | (interactive |
| 420 | (list |
| 421 | (hi-lock-regexp-okay |
| 422 | (read-regexp "Regexp to highlight line" 'regexp-history-last)) |
| 423 | (hi-lock-read-face-name))) |
| 424 | (or (facep face) (setq face 'hi-yellow)) |
| 425 | (unless hi-lock-mode (hi-lock-mode 1)) |
| 426 | (hi-lock-set-pattern |
| 427 | ;; The \\(?:...\\) grouping construct ensures that a leading ^, +, * or ? |
| 428 | ;; or a trailing $ in REGEXP will be interpreted correctly. |
| 429 | (concat "^.*\\(?:" regexp "\\).*$") face)) |
| 430 | |
| 431 | |
| 432 | ;;;###autoload |
| 433 | (defalias 'highlight-regexp 'hi-lock-face-buffer) |
| 434 | ;;;###autoload |
| 435 | (defun hi-lock-face-buffer (regexp &optional face) |
| 436 | "Set face of each match of REGEXP to FACE. |
| 437 | Interactively, prompt for REGEXP using `read-regexp', then FACE. |
| 438 | Use the global history list for FACE. |
| 439 | |
| 440 | Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, |
| 441 | use overlays for highlighting. If overlays are used, the |
| 442 | highlighting will not update as you type." |
| 443 | (interactive |
| 444 | (list |
| 445 | (hi-lock-regexp-okay |
| 446 | (read-regexp "Regexp to highlight" 'regexp-history-last)) |
| 447 | (hi-lock-read-face-name))) |
| 448 | (or (facep face) (setq face 'hi-yellow)) |
| 449 | (unless hi-lock-mode (hi-lock-mode 1)) |
| 450 | (hi-lock-set-pattern regexp face)) |
| 451 | |
| 452 | ;;;###autoload |
| 453 | (defalias 'highlight-phrase 'hi-lock-face-phrase-buffer) |
| 454 | ;;;###autoload |
| 455 | (defun hi-lock-face-phrase-buffer (regexp &optional face) |
| 456 | "Set face of each match of phrase REGEXP to FACE. |
| 457 | Interactively, prompt for REGEXP using `read-regexp', then FACE. |
| 458 | Use the global history list for FACE. |
| 459 | |
| 460 | When called interactively, replace whitespace in user-provided |
| 461 | regexp with arbitrary whitespace, and make initial lower-case |
| 462 | letters case-insensitive, before highlighting with `hi-lock-set-pattern'. |
| 463 | |
| 464 | Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, |
| 465 | use overlays for highlighting. If overlays are used, the |
| 466 | highlighting will not update as you type." |
| 467 | (interactive |
| 468 | (list |
| 469 | (hi-lock-regexp-okay |
| 470 | (hi-lock-process-phrase |
| 471 | (read-regexp "Phrase to highlight" 'regexp-history-last))) |
| 472 | (hi-lock-read-face-name))) |
| 473 | (or (facep face) (setq face 'hi-yellow)) |
| 474 | (unless hi-lock-mode (hi-lock-mode 1)) |
| 475 | (hi-lock-set-pattern regexp face)) |
| 476 | |
| 477 | ;;;###autoload |
| 478 | (defalias 'highlight-symbol-at-point 'hi-lock-face-symbol-at-point) |
| 479 | ;;;###autoload |
| 480 | (defun hi-lock-face-symbol-at-point () |
| 481 | "Highlight each instance of the symbol at point. |
| 482 | Uses the next face from `hi-lock-face-defaults' without prompting, |
| 483 | unless you use a prefix argument. |
| 484 | Uses `find-tag-default-as-symbol-regexp' to retrieve the symbol at point. |
| 485 | |
| 486 | This uses Font lock mode if it is enabled; otherwise it uses overlays, |
| 487 | in which case the highlighting will not update as you type." |
| 488 | (interactive) |
| 489 | (let* ((regexp (hi-lock-regexp-okay |
| 490 | (find-tag-default-as-symbol-regexp))) |
| 491 | (hi-lock-auto-select-face t) |
| 492 | (face (hi-lock-read-face-name))) |
| 493 | (or (facep face) (setq face 'hi-yellow)) |
| 494 | (unless hi-lock-mode (hi-lock-mode 1)) |
| 495 | (hi-lock-set-pattern regexp face))) |
| 496 | |
| 497 | (defun hi-lock-keyword->face (keyword) |
| 498 | (cadr (cadr (cadr keyword)))) ; Keyword looks like (REGEXP (0 'FACE) ...). |
| 499 | |
| 500 | (declare-function x-popup-menu "menu.c" (position menu)) |
| 501 | |
| 502 | (defun hi-lock--regexps-at-point () |
| 503 | (let ((regexps '())) |
| 504 | ;; When using overlays, there is no ambiguity on the best |
| 505 | ;; choice of regexp. |
| 506 | (let ((regexp (get-char-property (point) 'hi-lock-overlay-regexp))) |
| 507 | (when regexp (push regexp regexps))) |
| 508 | ;; With font-locking on, check if the cursor is on a highlighted text. |
| 509 | (let ((face-after (get-text-property (point) 'face)) |
| 510 | (face-before |
| 511 | (unless (bobp) (get-text-property (1- (point)) 'face))) |
| 512 | (faces (mapcar #'hi-lock-keyword->face |
| 513 | hi-lock-interactive-patterns))) |
| 514 | (unless (memq face-before faces) (setq face-before nil)) |
| 515 | (unless (memq face-after faces) (setq face-after nil)) |
| 516 | (when (and face-before face-after (not (eq face-before face-after))) |
| 517 | (setq face-before nil)) |
| 518 | (when (or face-after face-before) |
| 519 | (let* ((hi-text |
| 520 | (buffer-substring-no-properties |
| 521 | (if face-before |
| 522 | (or (previous-single-property-change (point) 'face) |
| 523 | (point-min)) |
| 524 | (point)) |
| 525 | (if face-after |
| 526 | (or (next-single-property-change (point) 'face) |
| 527 | (point-max)) |
| 528 | (point))))) |
| 529 | ;; Compute hi-lock patterns that match the |
| 530 | ;; highlighted text at point. Use this later in |
| 531 | ;; during completing-read. |
| 532 | (dolist (hi-lock-pattern hi-lock-interactive-patterns) |
| 533 | (let ((regexp (car hi-lock-pattern))) |
| 534 | (if (string-match regexp hi-text) |
| 535 | (push regexp regexps))))))) |
| 536 | regexps)) |
| 537 | |
| 538 | (defvar-local hi-lock--unused-faces nil |
| 539 | "List of faces that is not used and is available for highlighting new text. |
| 540 | Face names from this list come from `hi-lock-face-defaults'.") |
| 541 | |
| 542 | ;;;###autoload |
| 543 | (defalias 'unhighlight-regexp 'hi-lock-unface-buffer) |
| 544 | ;;;###autoload |
| 545 | (defun hi-lock-unface-buffer (regexp) |
| 546 | "Remove highlighting of each match to REGEXP set by hi-lock. |
| 547 | Interactively, prompt for REGEXP, accepting only regexps |
| 548 | previously inserted by hi-lock interactive functions. |
| 549 | If REGEXP is t (or if \\[universal-argument] was specified interactively), |
| 550 | then remove all hi-lock highlighting." |
| 551 | (interactive |
| 552 | (cond |
| 553 | (current-prefix-arg (list t)) |
| 554 | ((and (display-popup-menus-p) |
| 555 | (listp last-nonmenu-event) |
| 556 | use-dialog-box) |
| 557 | (catch 'snafu |
| 558 | (or |
| 559 | (x-popup-menu |
| 560 | t |
| 561 | (cons |
| 562 | `keymap |
| 563 | (cons "Select Pattern to Unhighlight" |
| 564 | (mapcar (lambda (pattern) |
| 565 | (list (car pattern) |
| 566 | (format |
| 567 | "%s (%s)" (car pattern) |
| 568 | (hi-lock-keyword->face pattern)) |
| 569 | (cons nil nil) |
| 570 | (car pattern))) |
| 571 | hi-lock-interactive-patterns)))) |
| 572 | ;; If the user clicks outside the menu, meaning that they |
| 573 | ;; change their mind, x-popup-menu returns nil, and |
| 574 | ;; interactive signals a wrong number of arguments error. |
| 575 | ;; To prevent that, we return an empty string, which will |
| 576 | ;; effectively disable the rest of the function. |
| 577 | (throw 'snafu '(""))))) |
| 578 | (t |
| 579 | ;; Un-highlighting triggered via keyboard action. |
| 580 | (unless hi-lock-interactive-patterns |
| 581 | (error "No highlighting to remove")) |
| 582 | ;; Infer the regexp to un-highlight based on cursor position. |
| 583 | (let* ((defaults (or (hi-lock--regexps-at-point) |
| 584 | (mapcar #'car hi-lock-interactive-patterns)))) |
| 585 | (list |
| 586 | (completing-read (if (null defaults) |
| 587 | "Regexp to unhighlight: " |
| 588 | (format "Regexp to unhighlight (default %s): " |
| 589 | (car defaults))) |
| 590 | hi-lock-interactive-patterns |
| 591 | nil t nil nil defaults)))))) |
| 592 | (dolist (keyword (if (eq regexp t) hi-lock-interactive-patterns |
| 593 | (list (assoc regexp hi-lock-interactive-patterns)))) |
| 594 | (when keyword |
| 595 | (let ((face (hi-lock-keyword->face keyword))) |
| 596 | ;; Make `face' the next one to use by default. |
| 597 | (when (symbolp face) ;Don't add it if it's a list (bug#13297). |
| 598 | (add-to-list 'hi-lock--unused-faces (face-name face)))) |
| 599 | (font-lock-remove-keywords nil (list keyword)) |
| 600 | (setq hi-lock-interactive-patterns |
| 601 | (delq keyword hi-lock-interactive-patterns)) |
| 602 | (remove-overlays |
| 603 | nil nil 'hi-lock-overlay-regexp (hi-lock--hashcons (car keyword))) |
| 604 | (font-lock-flush)))) |
| 605 | |
| 606 | ;;;###autoload |
| 607 | (defun hi-lock-write-interactive-patterns () |
| 608 | "Write interactively added patterns, if any, into buffer at point. |
| 609 | |
| 610 | Interactively added patterns are those normally specified using |
| 611 | `highlight-regexp' and `highlight-lines-matching-regexp'; they can |
| 612 | be found in variable `hi-lock-interactive-patterns'." |
| 613 | (interactive) |
| 614 | (if (null hi-lock-interactive-patterns) |
| 615 | (error "There are no interactive patterns")) |
| 616 | (let ((beg (point))) |
| 617 | (mapc |
| 618 | (lambda (pattern) |
| 619 | (insert (format "%s: (%s)\n" |
| 620 | hi-lock-file-patterns-prefix |
| 621 | (prin1-to-string pattern)))) |
| 622 | hi-lock-interactive-patterns) |
| 623 | (comment-region beg (point))) |
| 624 | (when (> (point) hi-lock-file-patterns-range) |
| 625 | (warn "Inserted keywords not close enough to top of file"))) |
| 626 | |
| 627 | ;; Implementation Functions |
| 628 | |
| 629 | (defun hi-lock-process-phrase (phrase) |
| 630 | "Convert regexp PHRASE to a regexp that matches phrases. |
| 631 | |
| 632 | Blanks in PHRASE replaced by regexp that matches arbitrary whitespace |
| 633 | and initial lower-case letters made case insensitive." |
| 634 | (let ((mod-phrase nil)) |
| 635 | ;; FIXME fragile; better to just bind case-fold-search? (Bug#7161) |
| 636 | (setq mod-phrase |
| 637 | (replace-regexp-in-string |
| 638 | "\\(^\\|\\s-\\)\\([a-z]\\)" |
| 639 | (lambda (m) (format "%s[%s%s]" |
| 640 | (match-string 1 m) |
| 641 | (upcase (match-string 2 m)) |
| 642 | (match-string 2 m))) phrase)) |
| 643 | ;; FIXME fragile; better to use search-spaces-regexp? |
| 644 | (setq mod-phrase |
| 645 | (replace-regexp-in-string |
| 646 | "\\s-+" "[ \t\n]+" mod-phrase nil t)))) |
| 647 | |
| 648 | (defun hi-lock-regexp-okay (regexp) |
| 649 | "Return REGEXP if it appears suitable for a font-lock pattern. |
| 650 | |
| 651 | Otherwise signal an error. A pattern that matches the null string is |
| 652 | not suitable." |
| 653 | (cond |
| 654 | ((null regexp) |
| 655 | (error "Regexp cannot match nil")) |
| 656 | ((string-match regexp "") |
| 657 | (error "Regexp cannot match an empty string")) |
| 658 | (t regexp))) |
| 659 | |
| 660 | (defun hi-lock-read-face-name () |
| 661 | "Return face for interactive highlighting. |
| 662 | When `hi-lock-auto-select-face' is non-nil, just return the next face. |
| 663 | Otherwise, or with a prefix argument, read a face from the minibuffer |
| 664 | with completion and history." |
| 665 | (unless hi-lock-interactive-patterns |
| 666 | (setq hi-lock--unused-faces hi-lock-face-defaults)) |
| 667 | (let* ((last-used-face |
| 668 | (when hi-lock-interactive-patterns |
| 669 | (face-name (hi-lock-keyword->face |
| 670 | (car hi-lock-interactive-patterns))))) |
| 671 | (defaults (append hi-lock--unused-faces |
| 672 | (cdr (member last-used-face hi-lock-face-defaults)) |
| 673 | hi-lock-face-defaults)) |
| 674 | face) |
| 675 | (if (and hi-lock-auto-select-face (not current-prefix-arg)) |
| 676 | (setq face (or (pop hi-lock--unused-faces) (car defaults))) |
| 677 | (setq face (completing-read |
| 678 | (format "Highlight using face (default %s): " |
| 679 | (car defaults)) |
| 680 | obarray 'facep t nil 'face-name-history defaults)) |
| 681 | ;; Update list of un-used faces. |
| 682 | (setq hi-lock--unused-faces (remove face hi-lock--unused-faces)) |
| 683 | ;; Grow the list of defaults. |
| 684 | (add-to-list 'hi-lock-face-defaults face t)) |
| 685 | (intern face))) |
| 686 | |
| 687 | (defun hi-lock-set-pattern (regexp face) |
| 688 | "Highlight REGEXP with face FACE." |
| 689 | ;; Hashcons the regexp, so it can be passed to remove-overlays later. |
| 690 | (setq regexp (hi-lock--hashcons regexp)) |
| 691 | (let ((pattern (list regexp (list 0 (list 'quote face) 'prepend)))) |
| 692 | ;; Refuse to highlight a text that is already highlighted. |
| 693 | (unless (assoc regexp hi-lock-interactive-patterns) |
| 694 | (push pattern hi-lock-interactive-patterns) |
| 695 | (if (and font-lock-mode (font-lock-specified-p major-mode)) |
| 696 | (progn |
| 697 | (font-lock-add-keywords nil (list pattern) t) |
| 698 | (font-lock-flush)) |
| 699 | (let* ((range-min (- (point) (/ hi-lock-highlight-range 2))) |
| 700 | (range-max (+ (point) (/ hi-lock-highlight-range 2))) |
| 701 | (search-start |
| 702 | (max (point-min) |
| 703 | (- range-min (max 0 (- range-max (point-max)))))) |
| 704 | (search-end |
| 705 | (min (point-max) |
| 706 | (+ range-max (max 0 (- (point-min) range-min)))))) |
| 707 | (save-excursion |
| 708 | (goto-char search-start) |
| 709 | (while (re-search-forward regexp search-end t) |
| 710 | (let ((overlay (make-overlay (match-beginning 0) (match-end 0)))) |
| 711 | (overlay-put overlay 'hi-lock-overlay t) |
| 712 | (overlay-put overlay 'hi-lock-overlay-regexp regexp) |
| 713 | (overlay-put overlay 'face face)) |
| 714 | (goto-char (match-end 0))))))))) |
| 715 | |
| 716 | (defun hi-lock-set-file-patterns (patterns) |
| 717 | "Replace file patterns list with PATTERNS and refontify." |
| 718 | (when (or hi-lock-file-patterns patterns) |
| 719 | (font-lock-remove-keywords nil hi-lock-file-patterns) |
| 720 | (setq hi-lock-file-patterns patterns) |
| 721 | (font-lock-add-keywords nil hi-lock-file-patterns t) |
| 722 | (font-lock-flush))) |
| 723 | |
| 724 | (defun hi-lock-find-patterns () |
| 725 | "Find patterns in current buffer for hi-lock." |
| 726 | (interactive) |
| 727 | (unless (memq major-mode hi-lock-exclude-modes) |
| 728 | (let ((all-patterns nil) |
| 729 | (target-regexp (concat "\\<" hi-lock-file-patterns-prefix ":"))) |
| 730 | (save-excursion |
| 731 | (save-restriction |
| 732 | (widen) |
| 733 | (goto-char (point-min)) |
| 734 | (re-search-forward target-regexp |
| 735 | (+ (point) hi-lock-file-patterns-range) t) |
| 736 | (beginning-of-line) |
| 737 | (while (and (re-search-forward target-regexp (+ (point) 100) t) |
| 738 | (not (looking-at "\\s-*end"))) |
| 739 | (condition-case nil |
| 740 | (setq all-patterns (append (read (current-buffer)) all-patterns)) |
| 741 | (error (message "Invalid pattern list expression at %d" |
| 742 | (line-number-at-pos))))))) |
| 743 | (when (and all-patterns |
| 744 | hi-lock-mode |
| 745 | (cond |
| 746 | ((eq this-command 'hi-lock-find-patterns) t) |
| 747 | ((functionp hi-lock-file-patterns-policy) |
| 748 | (funcall hi-lock-file-patterns-policy all-patterns)) |
| 749 | ((eq hi-lock-file-patterns-policy 'ask) |
| 750 | (y-or-n-p "Add patterns from this buffer to hi-lock? ")) |
| 751 | (t nil))) |
| 752 | (hi-lock-set-file-patterns all-patterns) |
| 753 | (if (called-interactively-p 'interactive) |
| 754 | (message "Hi-lock added %d patterns." (length all-patterns))))))) |
| 755 | |
| 756 | (defun hi-lock-font-lock-hook () |
| 757 | "Add hi-lock patterns to font-lock's." |
| 758 | (when font-lock-fontified |
| 759 | (font-lock-add-keywords nil hi-lock-file-patterns t) |
| 760 | (font-lock-add-keywords nil hi-lock-interactive-patterns t))) |
| 761 | |
| 762 | (defvar hi-lock--hashcons-hash |
| 763 | (make-hash-table :test 'equal :weakness t) |
| 764 | "Hash table used to hash cons regexps.") |
| 765 | |
| 766 | (defun hi-lock--hashcons (string) |
| 767 | "Return unique object equal to STRING." |
| 768 | (or (gethash string hi-lock--hashcons-hash) |
| 769 | (puthash string string hi-lock--hashcons-hash))) |
| 770 | |
| 771 | (defun hi-lock-unload-function () |
| 772 | "Unload the Hi-Lock library." |
| 773 | (global-hi-lock-mode -1) |
| 774 | ;; continue standard unloading |
| 775 | nil) |
| 776 | |
| 777 | (provide 'hi-lock) |
| 778 | |
| 779 | ;;; hi-lock.el ends here |