1;;; hi-lock.el --- minor mode for interactive automatic highlighting -*- lexical-binding: t -*- 2 3;; Copyright (C) 2000-2021 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 <https://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(defgroup hi-lock nil 91 "Interactively add and remove font-lock patterns for highlighting text." 92 :link '(custom-manual "(emacs)Highlight Interactively") 93 :group 'font-lock) 94 95(defcustom hi-lock-file-patterns-range 10000 96 "Limit of search in a buffer for hi-lock patterns. 97When a file is visited and hi-lock mode is on, patterns starting 98up to this limit are added to font-lock's patterns. See documentation 99of functions `hi-lock-mode' and `hi-lock-find-patterns'." 100 :type 'integer 101 :group 'hi-lock) 102 103(defcustom hi-lock-highlight-range 2000000 104 "Size of area highlighted by hi-lock when font-lock not active. 105Font-lock is not active in buffers that do their own highlighting, 106such as the buffer created by `list-colors-display'. In those buffers 107hi-lock patterns will only be applied over a range of 108`hi-lock-highlight-range' characters. If font-lock is active then 109highlighting will be applied throughout the buffer." 110 :type 'integer 111 :group 'hi-lock) 112 113(defcustom hi-lock-exclude-modes 114 '(rmail-mode mime/viewer-mode gnus-article-mode term-mode) 115 "List of major modes in which hi-lock will not run. 116For security reasons since font lock patterns can specify function 117calls." 118 :type '(repeat symbol) 119 :group 'hi-lock) 120 121(defcustom hi-lock-file-patterns-policy 'ask 122 "Specify when hi-lock should use patterns found in file. 123If `ask', prompt when patterns found in buffer; if bound to a function, 124use patterns when function returns t (function is called with patterns 125as first argument); if nil or `never' or anything else, don't use file 126patterns." 127 :type '(choice (const :tag "Do not use file patterns" never) 128 (const :tag "Ask about file patterns" ask) 129 (function :tag "Function to check file patterns")) 130 :group 'hi-lock 131 :version "22.1") 132 133;; It can have a function value. 134(put 'hi-lock-file-patterns-policy 'risky-local-variable t) 135 136(defcustom hi-lock-auto-select-face nil 137 "When nil, highlighting commands prompt for the face to use. 138When non-nil, highlighting command determine the faces to use 139by cycling through the faces in `hi-lock-face-defaults'." 140 :type 'boolean 141 :version "24.4") 142 143(defgroup hi-lock-faces nil 144 "Faces for hi-lock." 145 :group 'hi-lock 146 :group 'faces) 147 148(defface hi-yellow 149 '((((min-colors 88) (background dark)) 150 (:background "yellow1" :foreground "black")) 151 (((background dark)) (:background "yellow" :foreground "black")) 152 (((min-colors 88)) (:background "yellow1")) 153 (t (:background "yellow"))) 154 "Default face for hi-lock mode." 155 :group 'hi-lock-faces) 156 157(defface hi-pink 158 '((((background dark)) (:background "pink" :foreground "black")) 159 (t (:background "pink"))) 160 "Face for hi-lock mode." 161 :group 'hi-lock-faces) 162 163(defface hi-green 164 '((((min-colors 88) (background dark)) 165 (:background "light green" :foreground "black")) 166 (((background dark)) (:background "green" :foreground "black")) 167 (((min-colors 88)) (:background "light green")) 168 (t (:background "green"))) 169 "Face for hi-lock mode." 170 :group 'hi-lock-faces) 171 172(defface hi-blue 173 '((((background dark)) (:background "light blue" :foreground "black")) 174 (t (:background "light blue"))) 175 "Face for hi-lock mode." 176 :group 'hi-lock-faces) 177 178(defface hi-salmon 179 '((((min-colors 88) (background dark)) 180 (:background "light salmon" :foreground "black")) 181 (((background dark)) (:background "red" :foreground "black")) 182 (((min-colors 88)) (:background "light salmon")) 183 (t (:background "red"))) 184 "Face for hi-lock mode." 185 :group 'hi-lock-faces 186 :version "27.1") 187 188(defface hi-aquamarine 189 '((((min-colors 88) (background dark)) 190 (:background "aquamarine" :foreground "black")) 191 (((background dark)) (:background "blue" :foreground "black")) 192 (((min-colors 88)) (:background "aquamarine")) 193 (t (:background "blue"))) 194 "Face for hi-lock mode." 195 :group 'hi-lock-faces 196 :version "27.1") 197 198(defface hi-black-b 199 '((t (:weight bold))) 200 "Face for hi-lock mode." 201 :group 'hi-lock-faces) 202 203(defface hi-blue-b 204 '((((min-colors 88)) (:weight bold :foreground "blue1")) 205 (t (:weight bold :foreground "blue"))) 206 "Face for hi-lock mode." 207 :group 'hi-lock-faces) 208 209(defface hi-green-b 210 '((((min-colors 88)) (:weight bold :foreground "green3")) 211 (t (:weight bold :foreground "green"))) 212 "Face for hi-lock mode." 213 :group 'hi-lock-faces) 214 215(defface hi-red-b 216 '((((min-colors 88)) (:weight bold :foreground "firebrick2")) 217 (t (:weight bold :foreground "red"))) 218 "Face for hi-lock mode." 219 :group 'hi-lock-faces) 220 221(defface hi-black-hb 222 '((t (:weight bold :height 1.67 :inherit variable-pitch))) 223 "Face for hi-lock mode." 224 :group 'hi-lock-faces) 225 226(defvar-local hi-lock-file-patterns nil 227 "Patterns found in file for hi-lock. Should not be changed.") 228(put 'hi-lock-file-patterns 'permanent-local t) 229 230(defvar-local hi-lock-interactive-patterns nil 231 "Patterns provided to hi-lock by user. Should not be changed.") 232(put 'hi-lock-interactive-patterns 'permanent-local t) 233 234(defvar-local hi-lock-interactive-lighters nil 235 "Human-readable lighters for `hi-lock-interactive-patterns'.") 236(put 'hi-lock-interactive-lighters 'permanent-local t) 237 238(defvar hi-lock-face-defaults 239 '("hi-yellow" "hi-pink" "hi-green" "hi-blue" "hi-salmon" "hi-aquamarine" 240 "hi-black-b" "hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb") 241 "Default faces for hi-lock interactive functions.") 242 243(defvar hi-lock-file-patterns-prefix "Hi-lock" 244 "String used to identify hi-lock patterns at the start of files.") 245 246(defvar hi-lock-archaic-interface-message-used nil 247 "Non-nil if user alerted that `global-hi-lock-mode' is now the global switch. 248Earlier versions of hi-lock used `hi-lock-mode' as the global switch; 249the message is issued if it appears that `hi-lock-mode' is used assuming 250that older functionality. This variable avoids multiple reminders.") 251 252(defvar hi-lock-archaic-interface-deduce nil 253 "If non-nil, sometimes assume that `hi-lock-mode' means `global-hi-lock-mode'. 254Assumption is made if `hi-lock-mode' used in the *scratch* buffer while 255a library is being loaded.") 256 257(easy-menu-define hi-lock-menu nil 258 "Menu for hi-lock mode." 259 '("Hi Lock" 260 ["Highlight Regexp..." highlight-regexp 261 :help "Highlight text matching PATTERN (a regexp)."] 262 ["Highlight Phrase..." highlight-phrase 263 :help "Highlight text matching PATTERN (a regexp processed to match phrases)."] 264 ["Highlight Lines..." highlight-lines-matching-regexp 265 :help "Highlight lines containing match of PATTERN (a regexp)."] 266 ["Highlight Symbol at Point" highlight-symbol-at-point 267 :help "Highlight symbol found near point without prompting."] 268 ["Remove Highlighting..." unhighlight-regexp 269 :help "Remove previously entered highlighting pattern." 270 :enable hi-lock-interactive-patterns] 271 ["Patterns to Buffer" hi-lock-write-interactive-patterns 272 :help "Insert interactively added REGEXPs into buffer at point." 273 :enable hi-lock-interactive-patterns] 274 ["Patterns from Buffer" hi-lock-find-patterns 275 :help "Use patterns (if any) near top of buffer."])) 276 277(defvar hi-lock-map 278 (let ((map (make-sparse-keymap "Hi Lock"))) 279 (define-key map "\C-xwi" 'hi-lock-find-patterns) 280 (define-key map "\C-xwl" 'highlight-lines-matching-regexp) 281 (define-key map "\C-xwp" 'highlight-phrase) 282 (define-key map "\C-xwh" 'highlight-regexp) 283 (define-key map "\C-xw." 'highlight-symbol-at-point) 284 (define-key map "\C-xwr" 'unhighlight-regexp) 285 (define-key map "\C-xwb" 'hi-lock-write-interactive-patterns) 286 map) 287 "Key map for hi-lock.") 288 289;; Visible Functions 290 291;;;###autoload 292(define-minor-mode hi-lock-mode 293 "Toggle selective highlighting of patterns (Hi Lock mode). 294 295Hi Lock mode is automatically enabled when you invoke any of the 296highlighting commands listed below, such as \\[highlight-regexp]. 297To enable Hi Lock mode in all buffers, use `global-hi-lock-mode' 298or add (global-hi-lock-mode 1) to your init file. 299 300In buffers where Font Lock mode is enabled, patterns are 301highlighted using font lock. In buffers where Font Lock mode is 302disabled, patterns are applied using overlays; in this case, the 303highlighting will not be updated as you type. The Font Lock mode 304is considered \"enabled\" in a buffer if its `major-mode' 305causes `font-lock-specified-p' to return non-nil, which means 306the major mode specifies support for Font Lock. 307 308When Hi Lock mode is enabled, a \"Regexp Highlighting\" submenu 309is added to the \"Edit\" menu. The commands in the submenu, 310which can be called interactively, are: 311 312\\[highlight-regexp] REGEXP FACE 313 Highlight matches of pattern REGEXP in current buffer with FACE. 314 315\\[highlight-phrase] PHRASE FACE 316 Highlight matches of phrase PHRASE in current buffer with FACE. 317 (PHRASE can be any REGEXP, but spaces will be replaced by matches 318 to whitespace and initial lower-case letters will become case insensitive.) 319 320\\[highlight-lines-matching-regexp] REGEXP FACE 321 Highlight lines containing matches of REGEXP in current buffer with FACE. 322 323\\[highlight-symbol-at-point] 324 Highlight the symbol found near point without prompting, using the next 325 available face automatically. 326 327\\[unhighlight-regexp] REGEXP 328 Remove highlighting on matches of REGEXP in current buffer. 329 330\\[hi-lock-write-interactive-patterns] 331 Write active REGEXPs into buffer as comments (if possible). They may 332 be read the next time file is loaded or when the \\[hi-lock-find-patterns] command 333 is issued. The inserted regexps are in the form of font lock keywords. 334 (See `font-lock-keywords'.) They may be edited and re-loaded with \\[hi-lock-find-patterns], 335 any valid `font-lock-keywords' form is acceptable. When a file is 336 loaded the patterns are read if `hi-lock-file-patterns-policy' is 337 `ask' and the user responds y to the prompt, or if 338 `hi-lock-file-patterns-policy' is bound to a function and that 339 function returns t. 340 341\\[hi-lock-find-patterns] 342 Re-read patterns stored in buffer (in the format produced by \\[hi-lock-write-interactive-patterns]). 343 344When hi-lock is started and if the mode is not excluded or patterns 345rejected, the beginning of the buffer is searched for lines of the 346form: 347 Hi-lock: (FOO ...) 348 349where (FOO ...) is a list of patterns. The patterns must start before 350position \(number of characters into buffer) 351`hi-lock-file-patterns-range'. Patterns will be read until 352Hi-lock: end is found. A mode is excluded if it's in the list 353`hi-lock-exclude-modes'." 354 :group 'hi-lock 355 :lighter (:eval (if (or hi-lock-interactive-patterns 356 hi-lock-file-patterns) 357 " Hi" "")) 358 :global nil 359 :keymap hi-lock-map 360 (when (and (equal (buffer-name) "*scratch*") 361 load-in-progress 362 (not (called-interactively-p 'interactive)) 363 (not hi-lock-archaic-interface-message-used)) 364 (setq hi-lock-archaic-interface-message-used t) 365 (if hi-lock-archaic-interface-deduce 366 (global-hi-lock-mode hi-lock-mode) 367 (warn "%s" 368 "Possible archaic use of (hi-lock-mode). 369Use (global-hi-lock-mode 1) in .emacs to enable hi-lock for all buffers, 370use (hi-lock-mode 1) for individual buffers."))) 371 (if hi-lock-mode 372 ;; Turned on. 373 (progn 374 (define-key-after menu-bar-edit-menu [hi-lock] 375 (cons "Regexp Highlighting" hi-lock-menu)) 376 (hi-lock-find-patterns) 377 (add-hook 'font-lock-mode-hook 'hi-lock-font-lock-hook nil t) 378 ;; Remove regexps from font-lock-keywords (bug#13891). 379 (add-hook 'change-major-mode-hook (lambda () (hi-lock-mode -1)) nil t)) 380 ;; Turned off. 381 (when (or hi-lock-interactive-patterns 382 hi-lock-file-patterns) 383 (when hi-lock-interactive-patterns 384 (font-lock-remove-keywords nil hi-lock-interactive-patterns) 385 (setq hi-lock-interactive-patterns nil 386 hi-lock-interactive-lighters nil)) 387 (when hi-lock-file-patterns 388 (font-lock-remove-keywords nil hi-lock-file-patterns) 389 (setq hi-lock-file-patterns nil)) 390 (remove-overlays nil nil 'hi-lock-overlay t) 391 (font-lock-flush)) 392 (define-key-after menu-bar-edit-menu [hi-lock] nil) 393 (remove-hook 'font-lock-mode-hook 'hi-lock-font-lock-hook t))) 394 395;;;###autoload 396(define-globalized-minor-mode global-hi-lock-mode 397 hi-lock-mode turn-on-hi-lock-if-enabled 398 :group 'hi-lock) 399 400(defun turn-on-hi-lock-if-enabled () 401 (setq hi-lock-archaic-interface-message-used t) 402 (unless (memq major-mode hi-lock-exclude-modes) 403 (hi-lock-mode 1))) 404 405;;;###autoload 406(defalias 'highlight-lines-matching-regexp 'hi-lock-line-face-buffer) 407;;;###autoload 408(defun hi-lock-line-face-buffer (regexp &optional face) 409 "Highlight all lines that match REGEXP using FACE. 410The lines that match REGEXP will be displayed by merging 411the attributes of FACE with any other face attributes 412of text in those lines. 413 414Interactively, prompt for REGEXP using `read-regexp', then FACE. 415Use the global history list for FACE. 416 417If REGEXP contains upper case characters (excluding those preceded by `\\') 418and `search-upper-case' is non-nil, the matching is case-sensitive. 419 420Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, 421use overlays for highlighting. If overlays are used, the 422highlighting will not update as you type." 423 (interactive 424 (list 425 (hi-lock-regexp-okay 426 (read-regexp "Regexp to highlight line" 'regexp-history-last)) 427 (hi-lock-read-face-name))) 428 (or (facep face) (setq face 'hi-yellow)) 429 (unless hi-lock-mode (hi-lock-mode 1)) 430 (hi-lock-set-pattern 431 ;; The \\(?:...\\) grouping construct ensures that a leading ^, +, * or ? 432 ;; or a trailing $ in REGEXP will be interpreted correctly. 433 (concat "^.*\\(?:" regexp "\\).*\\(?:$\\)\n?") face nil nil 434 (if (and case-fold-search search-upper-case) 435 (isearch-no-upper-case-p regexp t) 436 case-fold-search))) 437 438 439;;;###autoload 440(defalias 'highlight-regexp 'hi-lock-face-buffer) 441;;;###autoload 442(defun hi-lock-face-buffer (regexp &optional face subexp lighter) 443 "Set face of each match of REGEXP to FACE. 444Interactively, prompt for REGEXP using `read-regexp', then FACE. 445Use the global history list for FACE. Limit face setting to the 446corresponding SUBEXP (interactively, the prefix argument) of REGEXP. 447If SUBEXP is omitted or nil, the entire REGEXP is highlighted. 448 449LIGHTER is a human-readable string that can be used to select 450a regexp to unhighlight by its name instead of selecting a possibly 451complex regexp or closure. 452 453If REGEXP contains upper case characters (excluding those preceded by `\\') 454and `search-upper-case' is non-nil, the matching is case-sensitive. 455 456Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, 457use overlays for highlighting. If overlays are used, the 458highlighting will not update as you type. The Font Lock mode 459is considered \"enabled\" in a buffer if its `major-mode' 460causes `font-lock-specified-p' to return non-nil, which means 461the major mode specifies support for Font Lock." 462 (interactive 463 (list 464 (hi-lock-regexp-okay 465 (read-regexp "Regexp to highlight" 466 (if (use-region-p) 467 (prog1 468 (buffer-substring (region-beginning) 469 (region-end)) 470 (deactivate-mark)) 471 'regexp-history-last))) 472 (hi-lock-read-face-name) 473 current-prefix-arg)) 474 (when (stringp face) 475 (setq face (intern face))) 476 (or (facep face) (setq face 'hi-yellow)) 477 (unless hi-lock-mode (hi-lock-mode 1)) 478 (hi-lock-set-pattern 479 regexp face subexp lighter 480 (if (and case-fold-search search-upper-case) 481 (isearch-no-upper-case-p regexp t) 482 case-fold-search) 483 search-spaces-regexp)) 484 485;;;###autoload 486(defalias 'highlight-phrase 'hi-lock-face-phrase-buffer) 487;;;###autoload 488(defun hi-lock-face-phrase-buffer (regexp &optional face) 489 "Set face of each match of phrase REGEXP to FACE. 490Interactively, prompt for REGEXP using `read-regexp', then FACE. 491Use the global history list for FACE. 492 493If REGEXP contains upper case characters (excluding those preceded by `\\') 494and `search-upper-case' is non-nil, the matching is case-sensitive. 495Also set `search-spaces-regexp' to the value of `search-whitespace-regexp'. 496 497Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, 498use overlays for highlighting. If overlays are used, the 499highlighting will not update as you type. The Font Lock mode 500is considered \"enabled\" in a buffer if its `major-mode' 501causes `font-lock-specified-p' to return non-nil, which means 502the major mode specifies support for Font Lock." 503 (interactive 504 (list 505 (hi-lock-regexp-okay 506 (read-regexp "Phrase to highlight" 'regexp-history-last)) 507 (hi-lock-read-face-name))) 508 (or (facep face) (setq face 'hi-yellow)) 509 (unless hi-lock-mode (hi-lock-mode 1)) 510 (hi-lock-set-pattern 511 regexp face nil nil 512 (if (and case-fold-search search-upper-case) 513 (isearch-no-upper-case-p regexp t) 514 case-fold-search) 515 search-whitespace-regexp)) 516 517;;;###autoload 518(defalias 'highlight-symbol-at-point 'hi-lock-face-symbol-at-point) 519;;;###autoload 520(defun hi-lock-face-symbol-at-point () 521 "Highlight each instance of the symbol at point. 522Uses the next face from `hi-lock-face-defaults' without prompting, 523unless you use a prefix argument. 524Uses `find-tag-default-as-symbol-regexp' to retrieve the symbol at point. 525 526If REGEXP contains upper case characters (excluding those preceded by `\\') 527and `search-upper-case' is non-nil, the matching is case-sensitive. 528 529This uses Font lock mode if it is enabled; otherwise it uses overlays, 530in which case the highlighting will not update as you type. The Font 531Lock mode is considered \"enabled\" in a buffer if its `major-mode' 532causes `font-lock-specified-p' to return non-nil, which means 533the major mode specifies support for Font Lock." 534 (interactive) 535 (let* ((regexp (hi-lock-regexp-okay 536 (find-tag-default-as-symbol-regexp))) 537 (hi-lock-auto-select-face t) 538 (face (hi-lock-read-face-name))) 539 (or (facep face) (setq face 'hi-yellow)) 540 (unless hi-lock-mode (hi-lock-mode 1)) 541 (hi-lock-set-pattern 542 regexp face nil nil 543 (if (and case-fold-search search-upper-case) 544 (isearch-no-upper-case-p regexp t) 545 case-fold-search)))) 546 547(defun hi-lock-keyword->face (keyword) 548 (cadr (cadr (cadr keyword)))) ; Keyword looks like (REGEXP (0 'FACE) ...). 549 550(declare-function x-popup-menu "menu.c" (position menu)) 551 552(defun hi-lock--regexps-at-point () 553 (let ((regexps '())) 554 ;; When using overlays, there is no ambiguity on the best 555 ;; choice of regexp. 556 (let ((regexp (get-char-property (point) 'hi-lock-overlay-regexp))) 557 (when regexp (push regexp regexps))) 558 ;; With font-locking on, check if the cursor is on a highlighted text. 559 (let* ((faces-after (get-text-property (point) 'face)) 560 (faces-before 561 (unless (bobp) (get-text-property (1- (point)) 'face))) 562 ;; Use proper-list-p to handle faces like (foreground-color . "red3") 563 (faces-after (if (proper-list-p faces-after) faces-after (list faces-after))) 564 (faces-before (if (proper-list-p faces-before) faces-before (list faces-before))) 565 (faces (mapcar #'hi-lock-keyword->face 566 hi-lock-interactive-patterns)) 567 (face-after (seq-some (lambda (face) (car (memq face faces))) faces-after)) 568 (face-before (seq-some (lambda (face) (car (memq face faces))) faces-before))) 569 (when (and face-before face-after (not (eq face-before face-after))) 570 (setq face-before nil)) 571 (when (or face-after face-before) 572 (let* ((hi-text 573 (buffer-substring-no-properties 574 (if face-before 575 (or (previous-single-property-change (point) 'face) 576 (point-min)) 577 (point)) 578 (if face-after 579 (or (next-single-property-change (point) 'face) 580 (point-max)) 581 (point))))) 582 ;; Compute hi-lock patterns that match the 583 ;; highlighted text at point. Use this later in 584 ;; during completing-read. 585 (dolist (hi-lock-pattern hi-lock-interactive-patterns) 586 (let ((regexp (or (car (rassq hi-lock-pattern hi-lock-interactive-lighters)) 587 (car hi-lock-pattern)))) 588 (if (string-match regexp hi-text) 589 (push regexp regexps))))))) 590 regexps)) 591 592(defvar-local hi-lock--unused-faces nil 593 "List of faces that is not used and is available for highlighting new text. 594Face names from this list come from `hi-lock-face-defaults'.") 595 596;;;###autoload 597(defalias 'unhighlight-regexp 'hi-lock-unface-buffer) 598;;;###autoload 599(defun hi-lock-unface-buffer (regexp) 600 "Remove highlighting of each match to REGEXP set by hi-lock. 601Interactively, prompt for REGEXP, accepting only regexps 602previously inserted by hi-lock interactive functions. 603If REGEXP is t (or if \\[universal-argument] was specified interactively), 604then remove all hi-lock highlighting." 605 (interactive 606 (cond 607 (current-prefix-arg (list t)) 608 ((and (display-popup-menus-p) 609 (listp last-nonmenu-event) 610 use-dialog-box) 611 (catch 'snafu 612 (or 613 (x-popup-menu 614 t 615 (cons 616 'keymap 617 (cons "Select Pattern to Unhighlight" 618 (mapcar (lambda (pattern) 619 (let ((lighter 620 (or (car (rassq pattern hi-lock-interactive-lighters)) 621 (car pattern)))) 622 (list lighter 623 (format 624 "%s (%s)" lighter 625 (hi-lock-keyword->face pattern)) 626 (cons nil nil) 627 lighter))) 628 hi-lock-interactive-patterns)))) 629 ;; If the user clicks outside the menu, meaning that they 630 ;; change their mind, x-popup-menu returns nil, and 631 ;; interactive signals a wrong number of arguments error. 632 ;; To prevent that, we return an empty string, which will 633 ;; effectively disable the rest of the function. 634 (throw 'snafu '(""))))) 635 (t 636 ;; Un-highlighting triggered via keyboard action. 637 (unless hi-lock-interactive-patterns 638 (user-error "No highlighting to remove")) 639 ;; Infer the regexp to un-highlight based on cursor position. 640 (let* ((defaults (or (hi-lock--regexps-at-point) 641 (mapcar (lambda (pattern) 642 (or (car (rassq pattern hi-lock-interactive-lighters)) 643 (car pattern))) 644 hi-lock-interactive-patterns)))) 645 (list 646 (completing-read (format-prompt "Regexp to unhighlight" (car defaults)) 647 (mapcar (lambda (pattern) 648 (cons (or (car (rassq pattern hi-lock-interactive-lighters)) 649 (car pattern)) 650 (cdr pattern))) 651 hi-lock-interactive-patterns) 652 nil t nil nil defaults)))))) 653 654 (when (assoc regexp hi-lock-interactive-lighters) 655 (setq regexp (cadr (assoc regexp hi-lock-interactive-lighters)))) 656 657 (dolist (keyword (if (eq regexp t) hi-lock-interactive-patterns 658 (list (assoc regexp hi-lock-interactive-patterns)))) 659 (when keyword 660 (let ((face (hi-lock-keyword->face keyword))) 661 ;; Make `face' the next one to use by default. 662 (when (symbolp face) ;Don't add it if it's a list (bug#13297). 663 (add-to-list 'hi-lock--unused-faces (face-name face)))) 664 ;; FIXME: Calling `font-lock-remove-keywords' causes 665 ;; `font-lock-specified-p' to go from nil to non-nil (because it 666 ;; calls font-lock-set-defaults). This is yet-another bug in 667 ;; font-lock-add/remove-keywords, which we circumvent here by 668 ;; testing `font-lock-fontified' (bug#19796). 669 (if font-lock-fontified (font-lock-remove-keywords nil (list keyword))) 670 (setq hi-lock-interactive-patterns 671 (delq keyword hi-lock-interactive-patterns)) 672 (remove-overlays 673 nil nil 'hi-lock-overlay-regexp 674 (or (car (rassq keyword hi-lock-interactive-lighters)) 675 (hi-lock--hashcons (car keyword)))) 676 (setq hi-lock-interactive-lighters 677 (rassq-delete-all keyword hi-lock-interactive-lighters)) 678 (font-lock-flush)))) 679 680;;;###autoload 681(defun hi-lock-write-interactive-patterns () 682 "Write interactively added patterns, if any, into buffer at point. 683 684Interactively added patterns are those normally specified using 685`highlight-regexp' and `highlight-lines-matching-regexp'; they can 686be found in variable `hi-lock-interactive-patterns'." 687 (interactive) 688 (if (null hi-lock-interactive-patterns) 689 (user-error "There are no interactive patterns")) 690 (let ((beg (point))) 691 (mapc 692 (lambda (pattern) 693 (insert (format "%s: (%s)\n" 694 hi-lock-file-patterns-prefix 695 (prin1-to-string pattern)))) 696 hi-lock-interactive-patterns) 697 (comment-region beg (point))) 698 (when (> (point) hi-lock-file-patterns-range) 699 (warn "Inserted keywords not close enough to top of file"))) 700 701;; Implementation Functions 702 703(defun hi-lock-regexp-okay (regexp) 704 "Return REGEXP if it appears suitable for a font-lock pattern. 705 706Otherwise signal an error. A pattern that matches the null string is 707not suitable." 708 (cond 709 ((null regexp) 710 (error "Regexp cannot match nil")) 711 ((string-match regexp "") 712 (error "Regexp cannot match an empty string")) 713 (t regexp))) 714 715(defun hi-lock-read-face-name () 716 "Return face for interactive highlighting. 717When `hi-lock-auto-select-face' is non-nil, just return the next face. 718Otherwise, or with a prefix argument, read a face from the minibuffer 719with completion and history." 720 (unless hi-lock-interactive-patterns 721 (setq hi-lock--unused-faces hi-lock-face-defaults)) 722 (let* ((last-used-face 723 (when hi-lock-interactive-patterns 724 (face-name (hi-lock-keyword->face 725 (car hi-lock-interactive-patterns))))) 726 (defaults (append hi-lock--unused-faces 727 (cdr (member last-used-face hi-lock-face-defaults)) 728 hi-lock-face-defaults)) 729 face) 730 (if (and hi-lock-auto-select-face (not current-prefix-arg)) 731 (setq face (or (pop hi-lock--unused-faces) (car defaults))) 732 (setq face (completing-read 733 (format-prompt "Highlight using face" (car defaults)) 734 obarray 'facep t nil 'face-name-history defaults)) 735 ;; Update list of un-used faces. 736 (setq hi-lock--unused-faces (remove face hi-lock--unused-faces)) 737 ;; Grow the list of defaults. 738 (add-to-list 'hi-lock-face-defaults face t)) 739 (intern face))) 740 741(defun hi-lock-set-pattern (regexp face &optional subexp lighter case-fold spaces-regexp) 742 "Highlight SUBEXP of REGEXP with face FACE. 743If omitted or nil, SUBEXP defaults to zero, i.e. the entire 744REGEXP is highlighted. LIGHTER is a human-readable string to 745display instead of a regexp. Non-nil CASE-FOLD ignores case. 746SPACES-REGEXP is a regexp to substitute spaces in font-lock search." 747 ;; Hashcons the regexp, so it can be passed to remove-overlays later. 748 (setq regexp (hi-lock--hashcons regexp)) 749 (setq subexp (or subexp 0)) 750 (let ((pattern (list (lambda (limit) 751 (let ((case-fold-search case-fold) 752 (search-spaces-regexp spaces-regexp)) 753 (re-search-forward regexp limit t))) 754 (list subexp (list 'quote face) 'prepend))) 755 (no-matches t)) 756 ;; Refuse to highlight a text that is already highlighted. 757 (if (or (assoc regexp hi-lock-interactive-patterns) 758 (assoc (or lighter regexp) hi-lock-interactive-lighters)) 759 (add-to-list 'hi-lock--unused-faces (face-name face)) 760 (push pattern hi-lock-interactive-patterns) 761 (push (cons (or lighter regexp) pattern) hi-lock-interactive-lighters) 762 (if (and font-lock-mode (font-lock-specified-p major-mode)) 763 (progn 764 (font-lock-add-keywords nil (list pattern) t) 765 (font-lock-flush)) 766 (let* ((range-min (- (point) (/ hi-lock-highlight-range 2))) 767 (range-max (+ (point) (/ hi-lock-highlight-range 2))) 768 (search-start 769 (max (point-min) 770 (- range-min (max 0 (- range-max (point-max)))))) 771 (search-end 772 (min (point-max) 773 (+ range-max (max 0 (- (point-min) range-min))))) 774 (case-fold-search case-fold) 775 (search-spaces-regexp spaces-regexp)) 776 (save-excursion 777 (goto-char search-start) 778 (while (re-search-forward regexp search-end t) 779 (when no-matches (setq no-matches nil)) 780 (let ((overlay (make-overlay (match-beginning subexp) 781 (match-end subexp)))) 782 (overlay-put overlay 'hi-lock-overlay t) 783 (overlay-put overlay 'hi-lock-overlay-regexp (or lighter regexp)) 784 (overlay-put overlay 'face face)) 785 (goto-char (match-end 0))) 786 (when no-matches 787 (add-to-list 'hi-lock--unused-faces (face-name face)) 788 (setq hi-lock-interactive-patterns 789 (cdr hi-lock-interactive-patterns) 790 hi-lock-interactive-lighters 791 (cdr hi-lock-interactive-lighters)))) 792 (when (or (> search-start (point-min)) (< search-end (point-max))) 793 (message "Hi-lock added only in range %d-%d" search-start search-end))))))) 794 795(defun hi-lock-set-file-patterns (patterns) 796 "Replace file patterns list with PATTERNS and refontify." 797 (when (or hi-lock-file-patterns patterns) 798 (font-lock-remove-keywords nil hi-lock-file-patterns) 799 (setq hi-lock-file-patterns patterns) 800 (font-lock-add-keywords nil hi-lock-file-patterns t) 801 (font-lock-flush))) 802 803;;;###autoload 804(defun hi-lock-find-patterns () 805 "Add patterns from the current buffer to the list of hi-lock patterns." 806 (interactive) 807 (unless (memq major-mode hi-lock-exclude-modes) 808 (let ((all-patterns nil) 809 (target-regexp (concat "\\<" hi-lock-file-patterns-prefix ":"))) 810 (save-excursion 811 (save-restriction 812 (widen) 813 (goto-char (point-min)) 814 (re-search-forward target-regexp 815 (+ (point) hi-lock-file-patterns-range) t) 816 (beginning-of-line) 817 (while (and (re-search-forward target-regexp (+ (point) 100) t) 818 (not (looking-at "\\s-*end"))) 819 (condition-case nil 820 (setq all-patterns (append (read (current-buffer)) all-patterns)) 821 (error (message "Invalid pattern list expression at line %d" 822 (line-number-at-pos))))))) 823 (when (and all-patterns 824 hi-lock-mode 825 (cond 826 ((eq this-command 'hi-lock-find-patterns) t) 827 ((functionp hi-lock-file-patterns-policy) 828 (funcall hi-lock-file-patterns-policy all-patterns)) 829 ((eq hi-lock-file-patterns-policy 'ask) 830 (y-or-n-p "Add patterns from this buffer to hi-lock? ")) 831 (t nil))) 832 (hi-lock-set-file-patterns all-patterns) 833 (if (called-interactively-p 'interactive) 834 (message "Hi-lock added %d patterns." (length all-patterns))))))) 835 836(defun hi-lock-font-lock-hook () 837 "Add hi-lock patterns to font-lock's." 838 (when font-lock-fontified 839 (font-lock-add-keywords nil hi-lock-file-patterns t) 840 (font-lock-add-keywords nil hi-lock-interactive-patterns t))) 841 842(defvar hi-lock--hashcons-hash 843 (make-hash-table :test 'equal :weakness t) 844 "Hash table used to hash cons regexps.") 845 846(defun hi-lock--hashcons (string) 847 "Return unique object equal to STRING." 848 (or (gethash string hi-lock--hashcons-hash) 849 (puthash string string hi-lock--hashcons-hash))) 850 851(defun hi-lock-unload-function () 852 "Unload the Hi-Lock library." 853 (global-hi-lock-mode -1) 854 ;; continue standard unloading 855 nil) 856 857(provide 'hi-lock) 858 859;;; hi-lock.el ends here 860