bug#11095: [PATCH] Re: bug#11095: 24.0.94; hi-lock-face-buffer/unhighlight-regexp': Augment?

[Jambunathan K]

Please review the attached patch.

The patch exposes exposes a bug in defcustom and defvar-local which I
will outline separately in a followup post (after another 2-3 hours).

ps: I only wish you had tested unhighlighting part.  It would have saved
some re-working for me.

=== modified file 'etc/NEWS'
--- etc/NEWS    2012-12-04 17:07:09 +0000
+++ etc/NEWS    2012-12-06 14:44:01 +0000
@@ -74,6 +74,15 @@ when its arg ADJACENT is non-nil (when c
 it works like the utility `uniq'.  Otherwise by default it deletes
 duplicate lines everywhere in the region without regard to adjacency.
 
+** Various improvements to hi-lock.el
+*** New user variables `hi-lock-faces' and `hi-lock-auto-select-face'
+*** Highlighting commands (`hi-lock-face-buffer', `hi-lock-face-phrase-buffer'
+and `hi-lock-line-face-buffer') now take a prefix argument which
+temporarily inverts the meaning of `hi-lock-auto-select-face'.
+*** Unhighlighting command (`hi-lock-unface-buffer') now un-highlights text at
+point.  When called interactively with C-u, removes all highlighting
+in current buffer.
+
 ** Tramp
 +++
 *** New connection method "adb", which allows to access Android

=== modified file 'lisp/ChangeLog'
--- lisp/ChangeLog      2012-12-06 09:15:27 +0000
+++ lisp/ChangeLog      2012-12-06 14:24:34 +0000
@@ -1,3 +1,18 @@
+2012-12-06  Jambunathan K  <kjambunathan@gmail.com>
+
+       * hi-lock.el (hi-lock-faces): New user variable.
+       (hi-lock--auto-select-face-defaults): Use `hi-lock-faces'.
+       (hi-lock-read-face-name): New optional param `toggle-auto-select'.
+       (hi-lock-line-face-buffer, hi-lock-face-buffer)
+       (hi-lock-face-phrase-buffer): Allow prefix argument to temporarily
+       toggle the value of `hi-lock-auto-select-face'.
+       (hi-lock--regexps-at-point, hi-lock-unface-buffer): Fix earlier
+       commit.
+       (hi-lock-set-pattern): Refuse to highlight a regexp that is
+       already highlighted.
+
+       * faces.el (face-at-point): Fix bug (Bug#11095).
+
 2012-12-06  Michael Albinus  <michael.albinus@gmx.de>
 
        * net/tramp.el (tramp-replace-environment-variables): Hide

=== modified file 'lisp/faces.el'
--- lisp/faces.el       2012-11-25 04:50:20 +0000
+++ lisp/faces.el       2012-12-05 19:35:05 +0000
@@ -1884,6 +1884,7 @@ Return nil if it has no specified face."
                        (get-char-property (point) 'face)
                        'default))
          (face (cond ((symbolp faceprop) faceprop)
+                    ((stringp faceprop) (intern-soft faceprop))
                      ;; List of faces (don't treat an attribute spec).
                      ;; Just use the first face.
                      ((and (consp faceprop) (not (keywordp (car faceprop)))

=== modified file 'lisp/hi-lock.el'
--- lisp/hi-lock.el     2012-12-04 21:13:47 +0000
+++ lisp/hi-lock.el     2012-12-06 14:02:42 +0000
@@ -213,13 +213,27 @@ When non-nil, each hi-lock command will
 
 (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.")
 
+(defcustom hi-lock-faces
+  (or
+   (when (boundp 'hi-lock-face-defaults)
+     (mapcar
+      (lambda (face-name) (intern-soft face-name))
+      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."
+  :type '(repeat face)
+  :group 'hi-lock
+  :version "24.4")
+
 (defvar-local hi-lock--auto-select-face-defaults
-  (let ((l (copy-sequence hi-lock-face-defaults)))
+  (let ((l (copy-sequence hi-lock-faces)))
     (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
@@ -410,8 +424,12 @@ versions before 22 use the following in
 ;;;###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, using a buffer-local history
+list for REGEXP .  When `hi-lock-auto-select-face' is non-nil,
+prompt for FACE using a global history list.  Otherwise, use the
+next of `hi-lock-faces'.  When invoked with
+\\[universal-argument] prefix, invert the meaning of
+`hi-lock-auto-select-face'.
 
 If Font Lock mode is enabled in the buffer, it is used to
 highlight REGEXP.  If Font Lock mode is disabled, overlays are
@@ -421,8 +439,9 @@ updated as you type."
    (list
     (hi-lock-regexp-okay
      (read-regexp "Regexp to highlight line" (car regexp-history)))
-    (hi-lock-read-face-name)))
-  (or (facep face) (setq face 'hi-yellow))
+    (let ((toggle-auto-select current-prefix-arg))
+      (hi-lock-read-face-name toggle-auto-select))))
+  (unless (facep face) (setq face (hi-lock-read-face-name)))
   (unless hi-lock-mode (hi-lock-mode 1))
   (hi-lock-set-pattern
    ;; The \\(?:...\\) grouping construct ensures that a leading ^, +, * or ?
@@ -435,8 +454,12 @@ updated as you type."
 ;;;###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, using a buffer-local history
+list for REGEXP .  When `hi-lock-auto-select-face' is non-nil,
+prompt for FACE using a global history list.  Otherwise, use the
+next of `hi-lock-faces'.  When invoked with
+\\[universal-argument] prefix, invert the meaning of
+`hi-lock-auto-select-face'.
 
 If Font Lock mode is enabled in the buffer, it is used to
 highlight REGEXP.  If Font Lock mode is disabled, overlays are
@@ -446,8 +469,9 @@ updated as you type."
    (list
     (hi-lock-regexp-okay
      (read-regexp "Regexp to highlight" (car regexp-history)))
-    (hi-lock-read-face-name)))
-  (or (facep face) (setq face 'hi-yellow))
+    (let ((toggle-auto-select current-prefix-arg))
+      (hi-lock-read-face-name toggle-auto-select))))
+  (unless (facep face) (setq face (hi-lock-read-face-name)))
   (unless hi-lock-mode (hi-lock-mode 1))
   (hi-lock-set-pattern regexp face))
 
@@ -457,7 +481,12 @@ updated as you type."
 (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.
+arbitrary whitespace and makes initial lower-case letters
+case-insensitive.  When `hi-lock-auto-select-face' is non-nil,
+prompt for FACE using a global history list.  Otherwise, use the
+next of `hi-lock-faces'.  When invoked with
+\\[universal-argument] prefix, invert the meaning of
+`hi-lock-auto-select-face'.
 
 If Font Lock mode is enabled in the buffer, it is used to
 highlight REGEXP.  If Font Lock mode is disabled, overlays are
@@ -467,9 +496,10 @@ updated as you type."
    (list
     (hi-lock-regexp-okay
      (hi-lock-process-phrase
-      (read-regexp "Phrase to highlight" (car regexp-history))))
-    (hi-lock-read-face-name)))
-  (or (facep face) (setq face 'hi-yellow))
+      (read-regexp "Phrase to highlight" (car regexp-history))))))
+  (let ((toggle-auto-select current-prefix-arg))
+    (hi-lock-read-face-name toggle-auto-select))
+  (unless (facep face) (setq face (hi-lock-read-face-name)))
   (unless hi-lock-mode (hi-lock-mode 1))
   (hi-lock-set-pattern regexp face))
 
@@ -482,26 +512,29 @@ updated as you type."
     (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))))
-    ;; 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)))
+        hi-lock-string-serialize-hash)))
+    ;; With font-locking on, check if cursor is on an highlighted
+    ;; text.
+    (when (member (list 'quote (face-at-point))
+                 (mapcar (lambda (pattern)
+                           (cadr (cadr pattern)))
+                         hi-lock-interactive-patterns))
          (let* ((hi-text
                  (buffer-substring-no-properties
-                  (previous-single-property-change (point) 'face)
-                  (next-single-property-change (point) 'face))))
+              (previous-single-char-property-change (point) 'face)
+              (next-single-char-property-change (point) 'face))))
            ;; 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))))))))
+           (when (string-match regexp hi-text)
+             (push regexp regexps))))))
+    regexps))
 
 ;;;###autoload
 (defalias 'unhighlight-regexp 'hi-lock-unface-buffer)
@@ -529,9 +562,7 @@ then remove all hi-lock highlighting."
                           (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,6 +588,7 @@ then remove all hi-lock highlighting."
   (dolist (keyword (if (eq regexp t) hi-lock-interactive-patterns
                      (list (assoc regexp hi-lock-interactive-patterns))))
     (when keyword
+      (setq regexp (car keyword))
       (font-lock-remove-keywords nil (list keyword))
       (setq hi-lock-interactive-patterns
             (delq keyword hi-lock-interactive-patterns))
@@ -615,31 +647,36 @@ not suitable."
       (error "Regexp cannot match an empty string")
     regexp))
 
-(defun hi-lock-read-face-name ()
+(defun hi-lock-read-face-name (&optional toggle-auto-select)
   "Return face name 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
+Otherwise, read face name from minibuffer with completion and history.
+
+When TOGGLE-AUTO-SELECT is non-nil, temporarily invert the value
+of `hi-lock-auto-select-face'."
+  (let ((auto-select
+        (if toggle-auto-select (not hi-lock-auto-select-face)
+          hi-lock-auto-select-face)))
+    (if auto-select
       ;; Return current head and rotate the face list.
       (pop hi-lock--auto-select-face-defaults)
-    (intern (completing-read
+      (intern
+       (let* ((face-names (mapcar #'face-name hi-lock-faces))
+             (prefix (try-completion "" face-names)))
+        (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)))
+         (cons (car face-names)
                      (if (and (stringp prefix)
-                              (not (equal prefix (car hi-lock-face-defaults))))
-                         (length prefix) 0)))
-             'face-name-history
-            (cdr hi-lock-face-defaults)))))
+                        (not (equal prefix (car face-names))))
+                   (length prefix) 0))
+         'face-name-history (cdr face-names)))))))
 
 (defun hi-lock-set-pattern (regexp face)
   "Highlight REGEXP with face FACE."
   (let ((pattern (list regexp (list 0 (list 'quote face) t))))
-    (unless (member pattern hi-lock-interactive-patterns)
+    ;; Check if REGEXP is already highlighted.
+    (unless (assoc regexp hi-lock-interactive-patterns)
       (push pattern hi-lock-interactive-patterns)
       (if font-lock-mode
          (progn

> There are three issues that I see with your commmit:
>
> Issue-1:  face-at-point broken?
> ===============================
>
> M-x toggle-debug-on-error RET
> M-x find-function RET face-at-point RET
> C-x w h
> C-x w r
>
>     Debugger entered--Lisp error: (error "Not a face: nil")
>       signal(error ("Not a face: nil"))
>       error("Not a face: %s" nil)
>       check-face(nil)
>       face-name(nil)
>       hi-lock--regexps-at-point()
>       byte-code("\203\305C\207\306 \203.    <\203.\n\203.\307\310\215\207
> \204!\311\312!\210\313 \314\f\204-\315\2022\316\317\f@\"
> \320\305\320\211\f&)C\207" [current-prefix-arg last-nonmenu-event 
> use-dialog-box hi-lock-interactive-patterns defaults t display-popup-menus-p 
> snafu (byte-code "\301\302\303\304\305\306\"BB\"\206.\307\310\311\"\207" 
> [hi-lock-interactive-patterns x-popup-menu t keymap "Select Pattern to 
> Unhighlight" mapcar #[(pattern) "@\301\302@\303A@A@A@!#\304\211B@F\207" 
> [pattern format "%s (%s)" symbol-name nil] 6] throw snafu ("")] 7) error "No 
> highlighting to remove" hi-lock--regexps-at-point completing-read "Regexp to 
> unhighlight: " format "Regexp to unhighlight (default %s): " nil] 8)
>       call-interactively(unhighlight-regexp nil nil)
>
> The reason is faceprop happens to be a string
>
> (get-char-property (point) 'face) 
>  : "hi-yellow"
>
> Issue-2:  Various issues with unhighlighting 
> ============================================
>
> Once you fix Issue-1 you will run in to other issues with
> un-highlighting.  Try highlighting and UN-highlighting in following 3
> ways
>
> 1. Buffer with font-lock-mode ON
> 2. Buffer with font-lock-mode OFF
> 3. Unhighlight from the menu
>
> Caveat:  Extra testing needed if /type/ of face names are changed 
> =================================================================
>
> hi-lock-face-defautls is currently a list of face names (stringp).  If
> it is made a defcustom, it will be cast to a list of symbols (symbolp).
> In some places, face names are expected and in some other places face as
> a symbol is used.  So you need to re-run the tests if move from
> string->symbols.
>
> Suggestion: In default faces, don't mix bold and foreground/background
> =======================================================================
>
> I am OK with defcustom of faces.  Something like
>
>     (defcustom 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."
>       :type '(repeat face)
>       :group 'hi-lock-faces)
>
> Bonus points if the default settings of the faces that go in there is
> revised as part of this bug.  I want to highlight variables in a buffer.
> So consistent policy of highlighting - a changed background of normal
> face - will require no additional work.
>
> Here is how my own faces look like.  Note that the first 4 come from
> "blue" space and the later 4 or so come from "pink" space, all chosen
> using agave.
>
> ps:  I will let you install a change for the above issues.