branch: scratch/mheerdegen-preview
commit 4ce7e1df18d3d2c20d9e903b8ccf5351999bfd1c
Author: Michael Heerdegen <michael_heerde...@web.de>
Commit: Michael Heerdegen <michael_heerde...@web.de>
WIP: Add el-search-hi-lock.el
---
packages/el-search/el-search-hi-lock.el | 293 ++++++++++++++++++++++++++++++++
packages/el-search/el-search.el | 26 ++-
2 files changed, 315 insertions(+), 4 deletions(-)
diff --git a/packages/el-search/el-search-hi-lock.el
b/packages/el-search/el-search-hi-lock.el
new file mode 100644
index 0000000..01fcd7a
--- /dev/null
+++ b/packages/el-search/el-search-hi-lock.el
@@ -0,0 +1,293 @@
+;;; el-search-hi-lock.el --- hi-lock with el-search patterns -*-
lexical-binding: t -*-
+
+;; Copyright (C) 2018 Free Software Foundation, Inc
+
+;; Author: Michael Heerdegen <michael_heerde...@web.de>
+;; Maintainer: Michael Heerdegen <michael_heerde...@web.de>
+;; Created: 2018_01_14
+;; Keywords: lisp
+
+
+;; This file is not part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file implements the counterpart of hi-lock.el for el-search
+;; patterns: Permanent highlighting of matches of specified patterns
+;; that is automatically updated when the buffer is edited. Unlike
+;; hi-lock, and in contrast to what the name "el-search-hi-lock"
+;; suggests, we can't use font-lock for this purpose. Instead, we use
+;; a timer to highlight the visible portions of the buffer.
+;;
+;; The entry points are `el-search-hi-lock-mode' to turn highlighting
+;; on and off, `el-search-hi-lock-add-pattern' to add patterns to be
+;; highlighted with specified faces (automatically turns on
+;; `el-search-hi-lock-mode'), and `el-search-hi-lock-remove-pattern'
+;; (removes patterns from the list of patterns to be highlighted).
+;;
+;; `el-search-hi-lock-add-pattern' can also be used in file and
+;; directory local variable specifications (with `eval').
+;;
+;; This is a bit slower than hi-lock. Don't use it with too costly
+;; patterns to avoid Emacs becoming sluggish.
+
+;;; Code:
+
+(require 'el-search)
+(eval-when-compile (require 'subr-x))
+(require 'hi-lock) ;faces
+
+(defgroup el-search-hi-lock nil
+ "Doc..."
+ :group 'el-search)
+
+;; These faces definitions are stolen from Drew's "highlight.el"
+(defface el-search-hi-lock-decent-1
+ '((((background dark)) (:background "#333333")) ;gray
+ (t (:background "#BBEEBB"))) ;a light green
+ "Doc...")
+(defface el-search-hi-lock-decent-3
+ '((((background dark)) (:background "#04602BC00000")) ; a very dark green
+ (t (:background "#FCFCE1E1FFFF"))) ; a light magenta
+ "Doc...")
+(defface el-search-hi-lock-decent-2
+ '((((background dark)) (:background "#316B22970000")) ; a very dark brown
+ (t (:background "#E1E1EAEAFFFF"))) ; a light blue
+ "Doc...")
+(defface el-search-hi-lock-decent-4
+ '((((background dark)) (:background "#00234F")) ; a dark blue
+ (t (:background "#E3FF9A"))) ; a light yellow
+ "Doc...")
+
+
+(defvar-local el-search-hi-lock-current-patterns '()
+ "Elements have the form (PATTERN MATCHER HM FACE).")
+
+(defvar-local el-search-hi-lock-overlays '())
+(defvar el-search-hi-lock-extra-window-heights 1.)
+
+(defmacro el-search-hi-lock--while-no-input (&rest body)
+ "Like `while-no-input' but without preceding `input-pending-p' test."
+ (declare (debug t) (indent 0))
+ (let ((catch-sym (make-symbol "input")))
+ `(with-local-quit
+ (catch ',catch-sym
+ (let ((throw-on-input ',catch-sym))
+ ,@body)))))
+
+(defvar el-search-hi-lock-window-in-progress nil)
+
+(defun el-search-hi-lock-window (&optional window)
+ ;; Return done when successfully hi-locked without user interruption,
+ ;; error when catched an error
+ (cl-callf or window (selected-window))
+ (let ((el-search-hi-lock-window-in-progress t))
+ (with-current-buffer (window-buffer window)
+ (condition-case nil
+ (let ((here (window-point window))
+ (start (window-start window))
+ (end (window-end window t))
+ (add-overlay (lambda (beg end face &optional priority)
+ (let ((ov (make-overlay beg end)))
+ (push ov el-search-hi-lock-overlays)
+ (overlay-put ov 'face face)
+ (overlay-put ov 'priority (or priority
100)))))
+ (delete-old-overlays
+ (let ((overlays (copy-sequence el-search-hi-lock-overlays)))
+ (lambda ()
+ (mapc #'delete-overlay overlays)
+ (cl-callf cl-set-difference el-search-hi-lock-overlays
overlays)))))
+ (when (numberp el-search-hi-lock-extra-window-heights)
+ (let ((window-lines (count-lines start end)))
+ (setq start (save-excursion
+ (goto-char start)
+ (line-beginning-position
+ (round (* -1
el-search-hi-lock-extra-window-heights window-lines)))))
+ (setq end (save-excursion
+ (goto-char end)
+ (line-beginning-position
+ (round (*
el-search-hi-lock-extra-window-heights window-lines)))))))
+ (el-search-hi-lock--while-no-input
+ (save-excursion
+ (goto-char start)
+ (let (string-or-comment-begin)
+ (while (and (not (bobp))
+ (setq string-or-comment-begin (nth 8
(syntax-ppss))))
+ (goto-char string-or-comment-begin)
+ (when (not (bobp) (backward-char)))))
+ (when-let ((pos (and (not (bobp))
+ (ignore-errors (scan-sexps (point) -1)))))
+ (goto-char pos))
+ (while (and (not (bobp))
+ (condition-case nil (progn (backward-up-list 1) t)
+ (scan-error nil)))
+ (mapc
+ (pcase-lambda (`(_pattern ,matcher ,_hm ,face ,priority))
+ (when (el-search--looking-at-1 matcher)
+ (funcall add-overlay (point) (el-search--end-of-sexp)
face priority)))
+ el-search-hi-lock-current-patterns)))
+ (let ((bound end))
+ (save-excursion
+ (goto-char end)
+ (let ((done nil))
+ (while (and (not done)
+ (not (bobp))
+ (condition-case nil (progn (backward-up-list
1) t)
+ (scan-error nil)))
+ (if (< start (point)) (setq bound
(el-search--end-of-sexp))
+ (setq done t)))))
+ (save-excursion
+ (mapc
+ (pcase-lambda (`(_pattern ,matcher ,hm ,face ,priority .
(,pred)))
+ (let (this-match-beg this-match-end (done nil))
+ (save-excursion
+ (goto-char start)
+ (while (not done)
+ (setq this-match-beg
+ (el-search--search-pattern-1 matcher t bound
hm))
+ (if (or (not this-match-beg)
+ (< end (point)))
+ (setq done t)
+ (goto-char this-match-beg)
+ (setq this-match-end (el-search--end-of-sexp))
+ (unless (or (< this-match-end start)
+ (and pred (let ((there (point)))
+ (save-excursion
+ (goto-char here)
+ (not (funcall pred
there))))))
+ (funcall add-overlay this-match-beg
this-match-end face priority))
+ (goto-char this-match-end)
+ (when (>= (point) end) (setq done t)))))))
+ el-search-hi-lock-current-patterns)))
+ (let ((window-scroll-functions
+ (remq #'el-search-hi-lock-trigger-update
window-scroll-functions)))
+ ;; Without this, highlight updating may get indefinitely
triggered
+ ;; from w-scroll-functions
+ (let ((throw-on-input nil))
+ (funcall delete-old-overlays)
+ (unless el-search-hi-lock-window-in-progress ;this may infrec
+ (redisplay))
+ 'done))))
+ ((scan-error end-of-buffer end-of-file invalid-read-syntax)
+ ;; Main case: incomplete sexps while typing
+ 'error)))))
+
+(defvar-local el-search--hi-lock-timer nil)
+
+(defvar el-search-hi-lock-mode)
+
+(defvar el-search-hi-lock-idle-time 0)
+(defvar el-search-hi-lock-idle-after-change-time 1.)
+
+(defun el-search-hi-lock-timer-function (window buffer)
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (when (timerp el-search--hi-lock-timer)
+ (cancel-timer el-search--hi-lock-timer)
+ (setq el-search--hi-lock-timer nil)))
+ (when (window-live-p window)
+ (with-current-buffer buffer
+ (when el-search-hi-lock-mode
+ (unless (member (el-search-hi-lock-window window) (list 'error
'done))
+ ;; User interrupt. Retry.
+ (el-search-hi-lock-trigger-update window 'retry)))))))
+
+(defun el-search-hi-lock-trigger-update (&rest args)
+ (cl-flet ((do-it (window &optional delay)
+ (when (window-live-p window)
+ (with-current-buffer (window-buffer window)
+ (if (timerp el-search--hi-lock-timer)
+ (progn
+ (when delay
+ (timer-set-time el-search--hi-lock-timer
+ (time-add (current-time)
delay)))
+ (timer-activate el-search--hi-lock-timer))
+ (setq-local el-search--hi-lock-timer
+ (run-with-idle-timer
+ (or delay el-search-hi-lock-idle-time)
nil
+ #'el-search-hi-lock-timer-function
+ window (window-buffer window))))))))
+ (pcase args
+ (`(,(and (pred framep) frame)) (mapc #'el-search-hi-lock-trigger-update
(window-list frame)))
+ (`(,(and (pred windowp) window) retry) (do-it window .15))
+ (`(,(and (pred windowp) window) . ,_) (do-it window))
+ (_ (do-it (selected-window)
+
el-search-hi-lock-idle-after-change-time)))))
+
+(defun el-search-hi-lock-update-buffer-windows (&optional buffer)
+ (mapc #'el-search-hi-lock-window (get-buffer-window-list (or buffer
(current-buffer)) nil t)))
+
+;;;###autoload
+(define-minor-mode el-search-hi-lock-mode
+ "Doc..."
+ nil (:eval (if el-search-hi-lock-current-patterns " ElHi" "")) nil
+ (if el-search-hi-lock-mode
+ (progn
+ (el-search-hi-lock-update-buffer-windows)
+ (add-hook 'after-change-functions
#'el-search-hi-lock-trigger-update t t)
+ (add-hook 'window-scroll-functions
#'el-search-hi-lock-trigger-update t t)
+ (add-hook 'window-size-change-functions
#'el-search-hi-lock-trigger-update t t)
+ (add-hook 'window-configuration-change-hook
#'el-search-hi-lock-trigger-update t t))
+ (remove-hook 'after-change-functions
#'el-search-hi-lock-trigger-update t)
+ (remove-hook 'window-scroll-functions
#'el-search-hi-lock-trigger-update t)
+ (remove-hook 'window-size-change-functions
#'el-search-hi-lock-trigger-update t)
+ (remove-hook 'window-configuration-change-hook
#'el-search-hi-lock-trigger-update t)
+ (mapc #'delete-overlay el-search-hi-lock-overlays)
+ (setq el-search-hi-lock-overlays nil)))
+
+(defun el-search-hi-lock-read-face-name ()
+ (let ((defaults (append (list "el-search-hi-lock-decent-1"
+ "el-search-hi-lock-decent-2"
+ "el-search-hi-lock-decent-3"
+ "el-search-hi-lock-decent-4")
+ hi-lock-face-defaults)))
+ (pcase-dolist (`(,_ ,_ ,_ ,(and face (let face-name (face-name face))))
+ (reverse el-search-hi-lock-current-patterns))
+ (ignore face)
+ (when (member face-name defaults)
+ (cl-callf2 delete face-name defaults)
+ (setcdr (last defaults) (cons face-name nil))))
+ (intern (completing-read
+ (format "Highlight using face (default %s): "
+ (car defaults))
+ obarray 'facep t nil 'face-name-history defaults))))
+
+;;;###autoload
+(defun el-search-hi-lock-add-pattern (pattern face &optional priority pred)
+ (interactive (list (el-search-read (el-search--read-pattern "Highlight
pattern: "))
+ (el-search-hi-lock-read-face-name)))
+ (cl-callf2 cons
+ `(,pattern
+ ,(el-search-make-matcher pattern)
+ ,(el-search-heuristic-matcher pattern)
+ ,face ,priority ,pred)
+ el-search-hi-lock-current-patterns)
+ (el-search-hi-lock-mode +1)
+ (el-search-hi-lock-update-buffer-windows))
+
+(defun el-search-hi-lock-remove-pattern (pattern)
+ (interactive (list (el-search-read (completing-read "Remove highlighting of
pattern: "
+ (mapcar (lambda (entry)
(prin1-to-string (car entry)))
+
el-search-hi-lock-current-patterns)))))
+ (setq el-search-hi-lock-current-patterns
+ (delq nil (mapcar (lambda (entry) (if (equal (car entry) pattern) nil
entry))
+ el-search-hi-lock-current-patterns)))
+ (el-search-hi-lock-update-buffer-windows))
+
+
+
+(provide 'el-search-hi-lock)
+;;; el-search-hi-lock.el ends here
diff --git a/packages/el-search/el-search.el b/packages/el-search/el-search.el
index c6a3093..297af5e 100644
--- a/packages/el-search/el-search.el
+++ b/packages/el-search/el-search.el
@@ -137,10 +137,15 @@
;; `window-end', or select the first match before `window-start',
;; respectively.
;;
-;; C-H, M-s e h (el-search-this-sexp)
-;; Grab the symbol or sexp under point and initiate an el-search
+;; C-T, M-s e t (el-search-this-sexp)
+;; Grab the symbol or sexp at point and initiate an el-search
;; for other occurrences.
;;
+;; C-H, M-s e h (el-search-highlight-pattern)
+;; Permanently highlight the current search pattern. This uses
+;; `el-search-hi-lock-mode' from "el-search-hi-lock.el". Use M-x
+;; `el-search-hi-lock-remove-pattern' to undo this.
+;;
;; M-x el-search-to-register
;; Save the current search to an Emacs register. Use C-x r j
;; (`jump-to-register') to make that search current and jump to
@@ -1704,7 +1709,7 @@ in, in order, when called with no arguments."
(keybind emacs-lisp-mode-map ?s #'el-search-pattern)
(keybind emacs-lisp-mode-map ?r #'el-search-pattern-backward)
(keybind emacs-lisp-mode-map ?% #'el-search-query-replace)
- (keybind emacs-lisp-mode-map ?h #'el-search-this-sexp) ;h like
in "highlight" or "here"
+ (keybind emacs-lisp-mode-map ?t #'el-search-this-sexp)
(keybind global-map ?j #'el-search-jump-to-search-head)
(keybind global-map ?a #'el-search-from-beginning)
(keybind global-map ?< #'el-search-from-beginning)
@@ -1713,6 +1718,7 @@ in, in order, when called with no arguments."
(keybind global-map ?n
#'el-search-continue-in-next-buffer)
(keybind global-map ?o #'el-search-occur)
+ (keybind emacs-lisp-mode-map ?h #'el-search-highlight-pattern)
(keybind el-search-read-expression-map ?s #'exit-minibuffer)
(keybind el-search-read-expression-map ?r #'exit-minibuffer)
@@ -1762,7 +1768,8 @@ any case."
el-search-last-buffer-match
el-search-skip-directory
el-search-continue-in-next-buffer
- el-search-occur))
+ el-search-occur
+ el-search-highlight-pattern))
(define-key transient-map (vector key) command))))
;; v and V are analogue to Ediff - FIXME: this doesn't fit into the
@@ -2938,6 +2945,17 @@ Use the normal search commands to seize the search."
(el-search--message-no-log "[No more matches before here]")
(sit-for 1))))
+(declare-function el-search-hi-lock-read-face-name 'el-search-hi-lock)
+
+(defun el-search-highlight-pattern ()
+ (interactive)
+ (require 'el-search-hi-lock)
+ (unless (el-search--pending-search-p)
+ (user-error "Please activate an el-search first"))
+ (el-search-hi-lock-add-pattern (el-search--current-pattern)
+ (el-search-hi-lock-read-face-name))
+ (message "Use M-x el-search-hi-lock-remove-pattern to unhighlight"))
+
;;;; El-Occur
