-;;; hi-lock.el --- minor mode for interactive automatic highlighting
+;;; hi-lock.el --- minor mode for interactive automatic highlighting -*- lexical-binding: t -*-
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2013 Free Software Foundation, Inc.
;; Author: David M. Koppelman <koppel@ece.lsu.edu>
;; Keywords: faces, minor-mode, matching, display
;;
;; Setup:
;;
-;; Put the following code in your .emacs file. This turns on
+;; Put the following code in your init file. This turns on
;; hi-lock mode and adds a "Regexp Highlighting" entry
;; to the edit menu.
;;
;; (global-hi-lock-mode 1)
;;
;; To enable the use of patterns found in files (presumably placed
-;; there by hi-lock) include the following in your .emacs file:
+;; there by hi-lock) include the following in your init file:
;;
;; (setq hi-lock-file-patterns-policy 'ask)
;;
;;; Code:
-(eval-and-compile
- (require 'font-lock))
+(require 'font-lock)
(defgroup hi-lock nil
"Interactively add and remove font-lock patterns for highlighting text."
;; It can have a function value.
(put 'hi-lock-file-patterns-policy 'risky-local-variable t)
+(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
+`hi-lock-face-defaults' without prompting."
+ :type 'boolean
+ :version "24.4")
+
(defgroup hi-lock-faces nil
"Faces for hi-lock."
:group 'hi-lock
"Face for hi-lock mode."
:group 'hi-lock-faces)
-(defvar hi-lock-file-patterns nil
+(defvar-local hi-lock-file-patterns nil
"Patterns found in file for hi-lock. Should not be changed.")
+(put 'hi-lock-file-patterns 'permanent-local t)
-(defvar hi-lock-interactive-patterns nil
+(defvar-local hi-lock-interactive-patterns nil
"Patterns provided to hi-lock by user. Should not be changed.")
+(put 'hi-lock-interactive-patterns 'permanent-local t)
+(define-obsolete-variable-alias 'hi-lock-face-history
+ 'hi-lock-face-defaults "23.1")
(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.")
-;(dolist (f hi-lock-face-defaults) (unless (facep f) (error "%s not a face" f)))
-
-(define-obsolete-variable-alias 'hi-lock-face-history
- 'hi-lock-face-defaults
- "23.1")
-
(define-obsolete-variable-alias 'hi-lock-regexp-history
'regexp-history
"23.1")
Assumption is made if `hi-lock-mode' used in the *scratch* buffer while
a library is being loaded.")
-(make-variable-buffer-local 'hi-lock-interactive-patterns)
-(put 'hi-lock-interactive-patterns 'permanent-local t)
-(make-variable-buffer-local 'hi-lock-file-patterns)
-(put 'hi-lock-file-patterns 'permanent-local t)
-
-(defvar hi-lock-menu (make-sparse-keymap "Hi Lock")
+(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)."))
+
+ (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)
"Menu for hi-lock mode.")
-(define-key-after hi-lock-menu [highlight-regexp]
- '(menu-item "Highlight Regexp..." highlight-regexp
- :help "Highlight text matching PATTERN (a regexp)."))
-
-(define-key-after hi-lock-menu [highlight-phrase]
- '(menu-item "Highlight Phrase..." highlight-phrase
- :help "Highlight text matching PATTERN (a regexp processed to match phrases)."))
-
-(define-key-after hi-lock-menu [highlight-lines-matching-regexp]
- '(menu-item "Highlight Lines..." highlight-lines-matching-regexp
- :help "Highlight lines containing match of PATTERN (a regexp)."))
-
-(define-key-after hi-lock-menu [unhighlight-regexp]
- '(menu-item "Remove Highlighting..." unhighlight-regexp
- :help "Remove previously entered highlighting pattern."
- :enable hi-lock-interactive-patterns))
-
-(define-key-after hi-lock-menu [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 hi-lock-menu [hi-lock-find-patterns]
- '(menu-item "Patterns from Buffer" hi-lock-find-patterns
- :help "Use patterns (if any) near top of buffer."))
-
-(defvar hi-lock-map (make-sparse-keymap "Hi Lock")
+(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)
+ (define-key map "\C-xwr" 'unhighlight-regexp)
+ (define-key map "\C-xwb" 'hi-lock-write-interactive-patterns)
+ map)
"Key map for hi-lock.")
-(define-key hi-lock-map "\C-xwi" 'hi-lock-find-patterns)
-(define-key hi-lock-map "\C-xwl" 'highlight-lines-matching-regexp)
-(define-key hi-lock-map "\C-xwp" 'highlight-phrase)
-(define-key hi-lock-map "\C-xwh" 'highlight-regexp)
-(define-key hi-lock-map "\C-xwr" 'unhighlight-regexp)
-(define-key hi-lock-map "\C-xwb" 'hi-lock-write-interactive-patterns)
-
;; Visible Functions
;;;###autoload
(define-minor-mode hi-lock-mode
- "Toggle minor mode for interactively adding font-lock highlighting patterns.
+ "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.
+
+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.
-If ARG positive, turn hi-lock on. Issuing a hi-lock command will also
-turn hi-lock on. To turn hi-lock on in all buffers use
-`global-hi-lock-mode' or in your .emacs file (global-hi-lock-mode 1).
-When hi-lock is turned on, a \"Regexp Highlighting\" submenu is added
-to the \"Edit\" menu. The commands in the submenu, which can be
-called interactively, are:
+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:
\\[highlight-regexp] REGEXP FACE
Highlight matches of pattern REGEXP in current buffer with FACE.
rejected, the beginning of the buffer is searched for lines of the
form:
Hi-lock: FOO
-where FOO is a list of patterns. These are added to the font lock
-keywords already present. 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'."
+
+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'."
:group 'hi-lock
:lighter (:eval (if (or hi-lock-interactive-patterns
hi-lock-file-patterns)
"Possible archaic use of (hi-lock-mode).
Use (global-hi-lock-mode 1) in .emacs to enable hi-lock for all buffers,
use (hi-lock-mode 1) for individual buffers. For compatibility with Emacs
-versions before 22 use the following in your .emacs file:
+versions before 22 use the following in your init file:
(if (functionp 'global-hi-lock-mode)
(global-hi-lock-mode 1)
(if hi-lock-mode
;; Turned on.
(progn
- (unless font-lock-mode (font-lock-mode 1))
(define-key-after menu-bar-edit-menu [hi-lock]
(cons "Regexp Highlighting" hi-lock-menu))
(hi-lock-find-patterns)
;;;###autoload
(defun hi-lock-line-face-buffer (regexp &optional face)
"Set face of all lines containing a match of REGEXP to FACE.
+Interactively, prompt for REGEXP then FACE, using a buffer-local
+history list for REGEXP and a global history list for FACE.
-Interactively, prompt for REGEXP then FACE. Buffer-local history
-list maintained for regexps, global history maintained for faces.
-\\<minibuffer-local-map>Use \\[previous-history-element] to retrieve previous history items,
-and \\[next-history-element] to retrieve default values.
-\(See info node `Minibuffer History'.)"
+If Font Lock mode is enabled in the buffer, it is used to
+highlight REGEXP. If Font Lock mode is disabled, overlays are
+used for highlighting; in this case, the highlighting will not be
+updated as you type."
(interactive
(list
(hi-lock-regexp-okay
;;;###autoload
(defun hi-lock-face-buffer (regexp &optional face)
"Set face of each match of REGEXP to FACE.
+Interactively, prompt for REGEXP then FACE, using a buffer-local
+history list for REGEXP and a global history list for FACE.
-Interactively, prompt for REGEXP then FACE. Buffer-local history
-list maintained for regexps, global history maintained for faces.
-\\<minibuffer-local-map>Use \\[previous-history-element] to retrieve previous history items,
-and \\[next-history-element] to retrieve default values.
-\(See info node `Minibuffer History'.)"
+If Font Lock mode is enabled in the buffer, it is used to
+highlight REGEXP. If Font Lock mode is disabled, overlays are
+used for highlighting; in this case, the highlighting will not be
+updated as you type."
(interactive
(list
(hi-lock-regexp-okay
;;;###autoload
(defun hi-lock-face-phrase-buffer (regexp &optional face)
"Set face of each match of phrase REGEXP to FACE.
+If called interactively, replaces whitespace in REGEXP with
+arbitrary whitespace and makes initial lower-case letters case-insensitive.
-Whitespace in REGEXP converted to arbitrary whitespace and initial
-lower-case letters made case insensitive."
+If Font Lock mode is enabled in the buffer, it is used to
+highlight REGEXP. If Font Lock mode is disabled, overlays are
+used for highlighting; in this case, the highlighting will not be
+updated as you type."
(interactive
(list
(hi-lock-regexp-okay
(unless hi-lock-mode (hi-lock-mode 1))
(hi-lock-set-pattern regexp face))
+(defun hi-lock-keyword->face (keyword)
+ (cadr (cadr (cadr keyword)))) ; Keyword looks like (REGEXP (0 'FACE) ...).
+
(declare-function x-popup-menu "menu.c" (position menu))
+(defun hi-lock--regexps-at-point ()
+ (let ((regexps '()))
+ ;; When using overlays, there is no ambiguity on the best
+ ;; choice of regexp.
+ (let ((regexp (get-char-property (point) 'hi-lock-overlay-regexp)))
+ (when regexp (push regexp regexps)))
+ ;; With font-locking on, check if the cursor is on a highlighted text.
+ (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)))))))
+ regexps))
+
+(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'.")
+
;;;###autoload
(defalias 'unhighlight-regexp 'hi-lock-unface-buffer)
;;;###autoload
(defun hi-lock-unface-buffer (regexp)
"Remove highlighting of each match to REGEXP set by hi-lock.
-
-Interactively, prompt for REGEXP. Buffer-local history of inserted
-regexp's maintained. Will accept only regexps inserted by hi-lock
-interactive functions. \(See `hi-lock-interactive-patterns'.\)
-\\<minibuffer-local-must-match-map>Use \\[minibuffer-complete] to complete a partially typed regexp.
-\(See info node `Minibuffer History'.\)"
+Interactively, prompt for REGEXP, accepting only regexps
+previously inserted by hi-lock interactive functions.
+If REGEXP is t (or if \\[universal-argument] was specified interactively),
+then remove all hi-lock highlighting."
(interactive
- (if (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)
- (symbol-name
- (car
- (cdr (car (cdr (car (cdr pattern))))))))
- (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 '(""))))
- (let ((history-list (mapcar (lambda (p) (car p))
- hi-lock-interactive-patterns)))
- (unless hi-lock-interactive-patterns
- (error "No highlighting to remove"))
+ (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)
+ (hi-lock-keyword->face pattern))
+ (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.
+ (let* ((defaults (or (hi-lock--regexps-at-point)
+ (mapcar #'car hi-lock-interactive-patterns))))
(list
- (completing-read "Regexp to unhighlight: "
- hi-lock-interactive-patterns nil t
- (car (car hi-lock-interactive-patterns))
- (cons 'history-list 1))))))
- (let ((keyword (assoc regexp hi-lock-interactive-patterns)))
+ (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))))
(when keyword
+ (let ((face (hi-lock-keyword->face keyword)))
+ ;; Make `face' the next one to use by default.
+ (when (symbolp face) ;Don't add it if it's a list (bug#13297).
+ (add-to-list 'hi-lock--unused-faces (face-name face))))
(font-lock-remove-keywords nil (list keyword))
(setq hi-lock-interactive-patterns
(delq keyword hi-lock-interactive-patterns))
(remove-overlays
- nil nil 'hi-lock-overlay-regexp (hi-lock-string-serialize regexp))
+ nil nil 'hi-lock-overlay-regexp (hi-lock--hashcons (car keyword)))
(when font-lock-fontified (font-lock-fontify-buffer)))))
;;;###autoload
Blanks in PHRASE replaced by regexp that matches arbitrary whitespace
and initial lower-case letters made case insensitive."
(let ((mod-phrase nil))
+ ;; FIXME fragile; better to just bind case-fold-search? (Bug#7161)
(setq mod-phrase
(replace-regexp-in-string
- "\\<[a-z]" (lambda (m) (format "[%s%s]" (upcase m) m)) phrase))
+ "\\(^\\|\\s-\\)\\([a-z]\\)"
+ (lambda (m) (format "%s[%s%s]"
+ (match-string 1 m)
+ (upcase (match-string 2 m))
+ (match-string 2 m))) phrase))
+ ;; FIXME fragile; better to use search-spaces-regexp?
(setq mod-phrase
(replace-regexp-in-string
"\\s-+" "[ \t\n]+" mod-phrase nil t))))
regexp))
(defun hi-lock-read-face-name ()
- "Read face name from minibuffer with completion and history."
- (intern (completing-read
- "Highlight using face: "
- obarray 'facep t
- (cons (car hi-lock-face-defaults)
- (let ((prefix
- (try-completion
- (substring (car hi-lock-face-defaults) 0 1)
- hi-lock-face-defaults)))
- (if (and (stringp prefix)
- (not (equal prefix (car hi-lock-face-defaults))))
- (length prefix) 0)))
- 'face-name-history
- (cdr hi-lock-face-defaults))))
+ "Return face for interactive highlighting.
+When `hi-lock-auto-select-face' is non-nil, just return the next face.
+Otherwise, read face name from minibuffer with completion and history."
+ (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)
+ (if (and hi-lock-auto-select-face (not current-prefix-arg))
+ (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)))
(defun hi-lock-set-pattern (regexp face)
"Highlight REGEXP with face FACE."
+ ;; Hashcons the regexp, so it can be passed to remove-overlays later.
+ (setq regexp (hi-lock--hashcons regexp))
(let ((pattern (list regexp (list 0 (list 'quote face) t))))
- (unless (member pattern hi-lock-interactive-patterns)
+ ;; Refuse to highlight a text that is already highlighted.
+ (unless (assoc regexp hi-lock-interactive-patterns)
(push pattern hi-lock-interactive-patterns)
- (if font-lock-fontified
+ (if font-lock-mode
(progn
(font-lock-add-keywords nil (list pattern) t)
(font-lock-fontify-buffer))
- (let* ((serial (hi-lock-string-serialize regexp))
- (range-min (- (point) (/ hi-lock-highlight-range 2)))
+ (let* ((range-min (- (point) (/ hi-lock-highlight-range 2)))
(range-max (+ (point) (/ hi-lock-highlight-range 2)))
(search-start
(max (point-min)
(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)
- (overlay-put overlay 'hi-lock-overlay-regexp serial)
+ (overlay-put overlay 'hi-lock-overlay-regexp regexp)
(overlay-put overlay 'face face))
(goto-char (match-end 0)))))))))
(font-lock-add-keywords nil hi-lock-file-patterns t)
(font-lock-add-keywords nil hi-lock-interactive-patterns t)))
-(defvar hi-lock-string-serialize-hash
- (make-hash-table :test 'equal)
- "Hash table used to assign unique numbers to strings.")
-
-(defvar hi-lock-string-serialize-serial 1
- "Number assigned to last new string in call to `hi-lock-string-serialize'.
-A string is considered new if it had not previously been used in a call to
-`hi-lock-string-serialize'.")
+(defvar hi-lock--hashcons-hash
+ (make-hash-table :test 'equal :weakness t)
+ "Hash table used to hash cons regexps.")
-(defun hi-lock-string-serialize (string)
- "Return unique serial number for STRING."
- (interactive)
- (let ((val (gethash string hi-lock-string-serialize-hash)))
- (if val val
- (puthash string
- (setq hi-lock-string-serialize-serial
- (1+ hi-lock-string-serialize-serial))
- hi-lock-string-serialize-hash)
- hi-lock-string-serialize-serial)))
+(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)))
(defun hi-lock-unload-function ()
"Unload the Hi-Lock library."
(provide 'hi-lock)
-;; arch-tag: d2e8fd07-4cc9-4c6f-a200-1e729bc54066
;;; hi-lock.el ends here