Commit 853c1ffc authored by Stefan Monnier's avatar Stefan Monnier
Browse files

* lisp/hi-lock.el: Rework the default face and the serialize regexp code.

(hi-lock--auto-select-face-defaults): Remove.
(hi-lock-string-serialize-serial): Remove.
(hi-lock--hashcons-hash): Rename from hi-lock-string-serialize-hash;
make weak.
(hi-lock--hashcons): Rename from hi-lock-string-serialize, return an
equal string.
(hi-lock-set-pattern): Adjust accordingly.
(hi-lock--regexps-at-point): Simplify accordingly.
(hi-lock--auto-select-face-defaults): Remove.
(hi-lock--last-face): New var to replace it.
(hi-lock-read-face-name): Rewrite.
(hi-lock-unface-buffer): Arrange for the face to be the next default.

Fixes: debbugs:11095
parent 1700db3c
2012-12-06 Stefan Monnier <monnier@iro.umontreal.ca>
* hi-lock.el: Rework the default face and the serialize regexp code.
(hi-lock--auto-select-face-defaults): Remove.
(hi-lock-string-serialize-serial): Remove.
(hi-lock--hashcons-hash): Rename from hi-lock-string-serialize-hash;
make weak.
(hi-lock--hashcons): Rename from hi-lock-string-serialize, return an
equal string.
(hi-lock-set-pattern): Adjust accordingly.
(hi-lock--regexps-at-point): Simplify accordingly.
(hi-lock--auto-select-face-defaults): Remove.
(hi-lock--last-face): New var to replace it.
(hi-lock-read-face-name): Rewrite (bug#11095).
(hi-lock-unface-buffer): Arrange for the face to be the next default.
2012-12-06 Michael Albinus <michael.albinus@gmx.de> 2012-12-06 Michael Albinus <michael.albinus@gmx.de>
   
* net/tramp.el (tramp-replace-environment-variables): Hide * net/tramp.el (tramp-replace-environment-variables):
compiler warning. Hide compiler warning.
(tramp-file-name-for-operation): Remove `executable-find', (tramp-file-name-for-operation): Remove `executable-find',
`start-process', `call-process' and `call-process-region'. `start-process', `call-process' and `call-process-region'.
   
* net/tramp-compat.el (top): Don't require 'tramp-util and 'tramp-vc. * net/tramp-compat.el (top): Don't require 'tramp-util and 'tramp-vc.
   
* net/tramp-gvfs.el (tramp-gvfs-dbus-event-error): Ensure backward * net/tramp-gvfs.el (tramp-gvfs-dbus-event-error): Ensure backward
compatibility. compatibility.
...@@ -54,8 +70,8 @@ ...@@ -54,8 +70,8 @@
* net/tramp-sh.el (tramp-do-copy-or-rename-file-out-of-band): * net/tramp-sh.el (tramp-do-copy-or-rename-file-out-of-band):
Check return code of copy command. Check return code of copy command.
   
* net/tramp-adb.el (tramp-adb-sdk-dir, tramp-adb-prompt): Use * net/tramp-adb.el (tramp-adb-sdk-dir, tramp-adb-prompt):
group `tramp'. Add version. Use group `tramp'. Add version.
   
2012-12-05 Chong Yidong <cyd@gnu.org> 2012-12-05 Chong Yidong <cyd@gnu.org>
   
...@@ -207,8 +223,8 @@ ...@@ -207,8 +223,8 @@
* progmodes/perl-mode.el (perl-current-defun-name): New. * progmodes/perl-mode.el (perl-current-defun-name): New.
(perl-mode): Use it. (perl-mode): Use it.
   
* progmodes/scheme.el (scheme-mode-variables, dsssl-mode): Use * progmodes/scheme.el (scheme-mode-variables, dsssl-mode):
lisp-current-defun-name. Use lisp-current-defun-name.
   
* textmodes/tex-mode.el (tex-current-defun-name): New. * textmodes/tex-mode.el (tex-current-defun-name): New.
(tex-common-initialization): Use it. (tex-common-initialization): Use it.
......
;;; hi-lock.el --- minor mode for interactive automatic highlighting ;;; hi-lock.el --- minor mode for interactive automatic highlighting -*- lexical-binding: t -*-
;; Copyright (C) 2000-2012 Free Software Foundation, Inc. ;; Copyright (C) 2000-2012 Free Software Foundation, Inc.
...@@ -138,7 +138,7 @@ patterns." ...@@ -138,7 +138,7 @@ patterns."
(defcustom hi-lock-auto-select-face nil (defcustom hi-lock-auto-select-face nil
"Non-nil if highlighting commands should not prompt for face names. "Non-nil if highlighting commands should not prompt for face names.
When non-nil, each hi-lock command will cycle through faces in When non-nil, each hi-lock command will cycle through faces in
`hi-lock-face-defaults'." `hi-lock-face-defaults' without prompting."
:type 'boolean :type 'boolean
:version "24.4") :version "24.4")
...@@ -218,14 +218,6 @@ When non-nil, each hi-lock command will cycle through faces in ...@@ -218,14 +218,6 @@ When non-nil, each hi-lock command will cycle through faces in
"hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb") "hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb")
"Default faces for hi-lock interactive functions.") "Default faces for hi-lock interactive functions.")
(defvar-local hi-lock--auto-select-face-defaults
(let ((l (copy-sequence hi-lock-face-defaults)))
(setcdr (last l) l))
"Circular list of faces used for interactive highlighting.
When `hi-lock-auto-select-face' is non-nil, use the face at the
head of this list for next interactive highlighting. See also
`hi-lock-read-face-name'.")
(define-obsolete-variable-alias 'hi-lock-regexp-history (define-obsolete-variable-alias 'hi-lock-regexp-history
'regexp-history 'regexp-history
"23.1") "23.1")
...@@ -479,15 +471,8 @@ updated as you type." ...@@ -479,15 +471,8 @@ updated as you type."
(let ((regexps '())) (let ((regexps '()))
;; When using overlays, there is no ambiguity on the best ;; When using overlays, there is no ambiguity on the best
;; choice of regexp. ;; choice of regexp.
(let ((desired-serial (get-char-property (let ((regexp (get-char-property (point) 'hi-lock-overlay-regexp)))
(point) 'hi-lock-overlay-regexp))) (when regexp (push regexp regexps)))
(when desired-serial
(catch 'regexp
(maphash
(lambda (regexp serial)
(when (= serial desired-serial)
(push regexp regexps)))
hi-lock-string-serialize-hash))))
;; With font-locking on, check if the cursor is on an highlighted text. ;; With font-locking on, check if the cursor is on an highlighted text.
;; Checking for hi-lock face is a good heuristic. ;; Checking for hi-lock face is a good heuristic.
(and (string-match "\\`hi-lock-" (face-name (face-at-point))) (and (string-match "\\`hi-lock-" (face-name (face-at-point)))
...@@ -503,6 +488,8 @@ updated as you type." ...@@ -503,6 +488,8 @@ updated as you type."
(if (string-match regexp hi-text) (if (string-match regexp hi-text)
(push regexp regexps)))))))) (push regexp regexps))))))))
(defvar-local hi-lock--last-face nil)
;;;###autoload ;;;###autoload
(defalias 'unhighlight-regexp 'hi-lock-unface-buffer) (defalias 'unhighlight-regexp 'hi-lock-unface-buffer)
;;;###autoload ;;;###autoload
...@@ -529,9 +516,7 @@ then remove all hi-lock highlighting." ...@@ -529,9 +516,7 @@ then remove all hi-lock highlighting."
(list (car pattern) (list (car pattern)
(format (format
"%s (%s)" (car pattern) "%s (%s)" (car pattern)
(symbol-name (cadr (cadr (cadr pattern))))
(car
(cdr (car (cdr (car (cdr pattern))))))))
(cons nil nil) (cons nil nil)
(car pattern))) (car pattern)))
hi-lock-interactive-patterns)))) hi-lock-interactive-patterns))))
...@@ -557,11 +542,16 @@ then remove all hi-lock highlighting." ...@@ -557,11 +542,16 @@ then remove all hi-lock highlighting."
(dolist (keyword (if (eq regexp t) hi-lock-interactive-patterns (dolist (keyword (if (eq regexp t) hi-lock-interactive-patterns
(list (assoc regexp hi-lock-interactive-patterns)))) (list (assoc regexp hi-lock-interactive-patterns))))
(when keyword (when keyword
(let ((face (cadr (cadr (cadr keyword)))))
;; Make `face' the next one to use by default.
(setq hi-lock--last-face
(cadr (member (symbol-name face)
(reverse hi-lock-face-defaults)))))
(font-lock-remove-keywords nil (list keyword)) (font-lock-remove-keywords nil (list keyword))
(setq hi-lock-interactive-patterns (setq hi-lock-interactive-patterns
(delq keyword hi-lock-interactive-patterns)) (delq keyword hi-lock-interactive-patterns))
(remove-overlays (remove-overlays
nil nil 'hi-lock-overlay-regexp (hi-lock-string-serialize regexp)) nil nil 'hi-lock-overlay-regexp (hi-lock--hashcons regexp))
(when font-lock-fontified (font-lock-fontify-buffer))))) (when font-lock-fontified (font-lock-fontify-buffer)))))
;;;###autoload ;;;###autoload
...@@ -616,28 +606,28 @@ not suitable." ...@@ -616,28 +606,28 @@ not suitable."
regexp)) regexp))
(defun hi-lock-read-face-name () (defun hi-lock-read-face-name ()
"Return face name for interactive highlighting. "Return face for interactive highlighting.
When `hi-lock-auto-select-face' is non-nil, just return the next face. When `hi-lock-auto-select-face' is non-nil, just return the next face.
Otherwise, read face name from minibuffer with completion and history." Otherwise, read face name from minibuffer with completion and history."
(if hi-lock-auto-select-face (let ((default (or (cadr (member hi-lock--last-face hi-lock-face-defaults))
;; Return current head and rotate the face list. (car hi-lock-face-defaults))))
(pop hi-lock--auto-select-face-defaults) (setq hi-lock--last-face
(intern (completing-read (if (and hi-lock-auto-select-face (not current-prefix-arg))
"Highlight using face: " default
obarray 'facep t (completing-read
(cons (car hi-lock-face-defaults) (format "Highlight using face (default %s): " default)
(let ((prefix obarray 'facep t nil 'face-name-history
(try-completion (append (member default hi-lock-face-defaults)
(substring (car hi-lock-face-defaults) 0 1) hi-lock-face-defaults))))
hi-lock-face-defaults))) (unless (member hi-lock--last-face hi-lock-face-defaults)
(if (and (stringp prefix) (setq hi-lock-face-defaults
(not (equal prefix (car hi-lock-face-defaults)))) (append hi-lock-face-defaults (list hi-lock--last-face))))
(length prefix) 0))) (intern hi-lock--last-face)))
'face-name-history
(cdr hi-lock-face-defaults)))))
(defun hi-lock-set-pattern (regexp face) (defun hi-lock-set-pattern (regexp face)
"Highlight REGEXP with face 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)))) (let ((pattern (list regexp (list 0 (list 'quote face) t))))
(unless (member pattern hi-lock-interactive-patterns) (unless (member pattern hi-lock-interactive-patterns)
(push pattern hi-lock-interactive-patterns) (push pattern hi-lock-interactive-patterns)
...@@ -645,8 +635,7 @@ Otherwise, read face name from minibuffer with completion and history." ...@@ -645,8 +635,7 @@ Otherwise, read face name from minibuffer with completion and history."
(progn (progn
(font-lock-add-keywords nil (list pattern) t) (font-lock-add-keywords nil (list pattern) t)
(font-lock-fontify-buffer)) (font-lock-fontify-buffer))
(let* ((serial (hi-lock-string-serialize regexp)) (let* ((range-min (- (point) (/ hi-lock-highlight-range 2)))
(range-min (- (point) (/ hi-lock-highlight-range 2)))
(range-max (+ (point) (/ hi-lock-highlight-range 2))) (range-max (+ (point) (/ hi-lock-highlight-range 2)))
(search-start (search-start
(max (point-min) (max (point-min)
...@@ -659,7 +648,7 @@ Otherwise, read face name from minibuffer with completion and history." ...@@ -659,7 +648,7 @@ Otherwise, read face name from minibuffer with completion and history."
(while (re-search-forward regexp search-end t) (while (re-search-forward regexp search-end t)
(let ((overlay (make-overlay (match-beginning 0) (match-end 0)))) (let ((overlay (make-overlay (match-beginning 0) (match-end 0))))
(overlay-put overlay 'hi-lock-overlay t) (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)) (overlay-put overlay 'face face))
(goto-char (match-end 0))))))))) (goto-char (match-end 0)))))))))
...@@ -709,27 +698,14 @@ Otherwise, read face name from minibuffer with completion and history." ...@@ -709,27 +698,14 @@ Otherwise, read face name from minibuffer with completion and history."
(font-lock-add-keywords nil hi-lock-file-patterns t) (font-lock-add-keywords nil hi-lock-file-patterns t)
(font-lock-add-keywords nil hi-lock-interactive-patterns t))) (font-lock-add-keywords nil hi-lock-interactive-patterns t)))
(defvar hi-lock-string-serialize-hash (defvar hi-lock--hashcons-hash
;; FIXME: don't map strings to numbers but to unique strings via (make-hash-table :test 'equal :weakness t)
;; hash-consing, with a weak hash-table. "Hash table used to hash cons regexps.")
(make-hash-table :test 'equal)
"Hash table used to assign unique numbers to strings.")
(defvar hi-lock-string-serialize-serial 1 (defun hi-lock--hashcons (string)
"Number assigned to last new string in call to `hi-lock-string-serialize'. "Return unique object equal to STRING."
A string is considered new if it had not previously been used in a call to (or (gethash string hi-lock--hashcons-hash)
`hi-lock-string-serialize'.") (puthash string string hi-lock--hashcons-hash)))
(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-unload-function () (defun hi-lock-unload-function ()
"Unload the Hi-Lock library." "Unload the Hi-Lock library."
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment