[Emacs-diffs] /srv/bzr/emacs/trunk r111129: * lisp/hi-lock.el: Rework the default face and the serialize regexp code.

[Stefan Monnier]

------------------------------------------------------------
revno: 111129
fixes bug: http://debbugs.gnu.org/cgi/bugreport.cgi?bug=11095
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Thu 2012-12-06 11:17:11 -0500
message:
  * 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.
modified:
  lisp/ChangeLog
  lisp/hi-lock.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2012-12-06 09:15:27 +0000
+++ b/lisp/ChangeLog    2012-12-06 16:17:11 +0000
@@ -1,11 +1,27 @@
+2012-12-06  Stefan Monnier  <address@hidden>
+
+       * 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  <address@hidden>
 
-       * net/tramp.el (tramp-replace-environment-variables): Hide
-       compiler warning.
+       * net/tramp.el (tramp-replace-environment-variables):
+       Hide compiler warning.
        (tramp-file-name-for-operation): Remove `executable-find',
        `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
        compatibility.
@@ -54,8 +70,8 @@
        * net/tramp-sh.el (tramp-do-copy-or-rename-file-out-of-band):
        Check return code of copy command.
 
-       * net/tramp-adb.el (tramp-adb-sdk-dir, tramp-adb-prompt): Use
-       group `tramp'.  Add version.
+       * net/tramp-adb.el (tramp-adb-sdk-dir, tramp-adb-prompt):
+       Use group `tramp'.  Add version.
 
 2012-12-05  Chong Yidong  <address@hidden>
 
@@ -207,8 +223,8 @@
        * progmodes/perl-mode.el (perl-current-defun-name): New.
        (perl-mode): Use it.
 
-       * progmodes/scheme.el (scheme-mode-variables, dsssl-mode): Use
-       lisp-current-defun-name.
+       * progmodes/scheme.el (scheme-mode-variables, dsssl-mode):
+       Use lisp-current-defun-name.
 
        * textmodes/tex-mode.el (tex-current-defun-name): New.
        (tex-common-initialization): Use it.

=== modified file 'lisp/hi-lock.el'
--- a/lisp/hi-lock.el   2012-12-04 21:13:47 +0000
+++ b/lisp/hi-lock.el   2012-12-06 16:17:11 +0000
@@ -1,4 +1,4 @@
-;;; 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.
 
@@ -138,7 +138,7 @@
 (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'."
+`hi-lock-face-defaults' without prompting."
   :type 'boolean
   :version "24.4")
 
@@ -218,14 +218,6 @@
     "hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb")
   "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
                                 'regexp-history
                                 "23.1")
@@ -479,15 +471,8 @@
   (let ((regexps '()))
     ;; When using overlays, there is no ambiguity on the best
     ;; choice of regexp.
-    (let ((desired-serial (get-char-property
-                           (point) 'hi-lock-overlay-regexp)))
-      (when desired-serial
-        (catch 'regexp
-          (maphash
-           (lambda (regexp serial)
-             (when (= serial desired-serial)
-               (push regexp regexps)))
-           hi-lock-string-serialize-hash))))
+    (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 an highlighted text.
     ;; Checking for hi-lock face is a good heuristic.
     (and (string-match "\\`hi-lock-" (face-name (face-at-point)))
@@ -503,6 +488,8 @@
                (if (string-match regexp hi-text)
                    (push regexp regexps))))))))
 
+(defvar-local hi-lock--last-face nil)
+
 ;;;###autoload
 (defalias 'unhighlight-regexp 'hi-lock-unface-buffer)
 ;;;###autoload
@@ -529,9 +516,7 @@
                           (list (car pattern)
                                 (format
                                  "%s (%s)" (car pattern)
-                                 (symbol-name
-                                  (car
-                                   (cdr (car (cdr (car (cdr pattern))))))))
+                                 (cadr (cadr (cadr pattern))))
                                 (cons nil nil)
                                 (car pattern)))
                         hi-lock-interactive-patterns))))
@@ -557,11 +542,16 @@
   (dolist (keyword (if (eq regexp t) hi-lock-interactive-patterns
                      (list (assoc regexp hi-lock-interactive-patterns))))
     (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))
       (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 regexp))
       (when font-lock-fontified (font-lock-fontify-buffer)))))
 
 ;;;###autoload
@@ -616,28 +606,28 @@
     regexp))
 
 (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.
 Otherwise, read face name from minibuffer with completion and history."
-  (if hi-lock-auto-select-face
-      ;; Return current head and rotate the face list.
-      (pop hi-lock--auto-select-face-defaults)
-    (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)))))
+  (let ((default (or (cadr (member hi-lock--last-face hi-lock-face-defaults))
+                      (car hi-lock-face-defaults))))
+    (setq hi-lock--last-face
+          (if (and hi-lock-auto-select-face (not current-prefix-arg))
+              default
+            (completing-read
+             (format "Highlight using face (default %s): " default)
+             obarray 'facep t nil 'face-name-history
+             (append (member default hi-lock-face-defaults)
+                     hi-lock-face-defaults))))
+    (unless (member hi-lock--last-face hi-lock-face-defaults)
+      (setq hi-lock-face-defaults
+            (append hi-lock-face-defaults (list hi-lock--last-face))))
+    (intern hi-lock--last-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)
       (push pattern hi-lock-interactive-patterns)
@@ -645,8 +635,7 @@
          (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)
@@ -659,7 +648,7 @@
             (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)))))))))
 
@@ -709,27 +698,14 @@
     (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
-  ;; FIXME: don't map strings to numbers but to unique strings via
-  ;; hash-consing, with a weak hash-table.
-  (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'.")
-
-(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)))
+(defvar hi-lock--hashcons-hash
+  (make-hash-table :test 'equal :weakness t)
+  "Hash table used to hash cons regexps.")
+
+(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."