* bug#50766: Regexp paren pairs in query-replace-regexp prompt should be highlighted
2021-10-01 14:28 ` ndame via Bug reports for GNU Emacs, the Swiss army knife of text editors
@ 2021-10-01 15:00 ` martin rudalics
0 siblings, 0 replies; 23+ messages in thread
From: martin rudalics @ 2021-10-01 15:00 UTC (permalink / raw)
To: ndame, Lars Ingebrigtsen; +Cc: 50766
[-- Attachment #1: Type: text/plain, Size: 430 bytes --]
> I wonder if it could be a generic feature which besides working in the
> minibuffer for regexps would also work when typing escaped parens in
> in strings, e.g. when using a string regexp in a program:
>
> "stuff ( \\( ) "
>
> Here it could indicate the mismatching parens.
I can only offer you my old regexp-lock-mode (attached). In an .el
buffer do M-x turn-on-regexp-lock-mode and tell me how it works.
martin
[-- Attachment #2: regexp-lock.el --]
[-- Type: text/x-emacs-lisp, Size: 70051 bytes --]
;;; regexp-lock.el --- minor mode for highlighting Emacs Lisp regexps
;; Copyright (C) 2005 Martin Rudalics
;; Time-stamp: "2021-10-01 12:10:57 martin"
;; Author: Martin Rudalics <rudalics@gmx.at>
;; Keywords: regular expressions
;; Version: 0.1
;; regexp-lock.el 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 2, or (at your option)
;; any later version.
;; regexp-lock.el 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.
;;; Commentary:
;; Regexp Lock is a minor mode for highlighting regular expressions in Emacs
;; Lisp mode.
;; `regexp-lock-mode' turns on/off Regexp Lock in the current buffer. For
;; further information consult the documentation of `regexp-lock-mode'.
;; To turn on Regexp Lock in any Emacs Lisp file you open, add the lines
;; (require 'regexp-lock)
;; (add-hook 'emacs-lisp-mode-hook 'turn-on-regexp-lock-mode)
;; to your .emacs.
;;; Code:
;; _____________________________________________________________________________
;;
;;; Faces and customizable variables
;; _____________________________________________________________________________
;;
(defgroup regexp-lock nil
"Highlight regular expressions in Lisp modes."
:version "22.1"
:group 'font-lock)
(defface regexp-lock-regexp
'((((class color)) :background "Grey87")
(t :underline t))
"Face for highlighting regexp at point."
:group 'regexp-lock)
(defface regexp-lock-group
'((((class color)) :bold t :foreground "Black" :background "Orange")
(t :bold t))
"Face for highlighting group numbers in regexp at point."
:group 'regexp-lock)
(defface regexp-lock-match
'((((class color)) :background "Turquoise1")
(t :underline t))
"Face for highlighting match of regexp at point."
:group 'regexp-lock)
(defface regexp-lock-match-group
'((((class color)) :bold t :foreground "Black" :background "Turquoise1")
(t :bold t))
"Face for highlighting group numbers in match of regexp at point."
:group 'regexp-lock)
(defface regexp-lock-match-other
'((((class color)) :background "PaleTurquoise1")
(t :underline t))
"Face for highlighting other matches of regexp at point."
:group 'regexp-lock)
(defcustom regexp-lock-minor-mode-string nil
"*String to display in mode line when Regexp Lock is enabled."
:type '(choice string (const :tag "none" nil))
:group 'regexp-lock)
(defcustom regexp-lock-regexp-string
"\\\\\\\\[](|)>}`'=_sSwWcCbB0-9]\\|\\[\\(?:[ ^:]\\|\\\\[tnf]\\)\\|\\][*+?]"
"*Strings matching this regexp are considered regexp subexpressions.
This regexp is used to discriminate strings representing regular
expressions from \"ordinary\" strings. The default value has Regexp
Lock search for one of the following:
- two backslashes preceding any of the characters expected in regexp
backslash constructs but \"[\", \"{\" and \"<\" - the latter being
excluded because the corresponding constructs have a special meaning
in `substitute-command-keys'
- a left bracket followed by a space, a caret, a colon, or a backslash
that precedes one of the characters \"t\", \"n\", or \"f\"
- a right bracket followed by one of \"*\", \"+\", or \"?\"
If any of these items is present in a string, that individual string is
considered part of a regular expression. If, moreover, the string
literally appears within the argument list of a `concat' or `mapconcat',
all components of that list are considered regular expressions too."
:type 'regexp
:group 'regexp-lock)
(defcustom regexp-lock-redo-delay 0.1
"*Time in seconds Regexp Lock waits before refontifying text.
By default, Regexp Lock refontifies text in order to correctly assign
the text properties of all regexps displayed. When the value of this
variable is nil Regexp Lock never refontifies text. As a consequence
regexps may appear improperly fontified after a buffer has been altered,
scrolled, or is displayed for the first time."
:type '(choice (const :tag "never" nil) (number :tag "seconds"))
:set (lambda (symbol value)
(set-default symbol value)
(when (boundp 'regexp-lock-redo-timer)
(when regexp-lock-redo-timer
(cancel-timer regexp-lock-redo-timer)
(setq regexp-lock-redo-timer nil))
(when value
(setq regexp-lock-redo-timer
(run-with-idle-timer value t 'regexp-lock-redo)))))
:group 'regexp-lock)
(defcustom regexp-lock-pause nil
"*Time in seconds Regexp Lock pauses during refontifying and rechecking.
When the value of this variable is nil `regexp-lock-redo' and
`regexp-lock-recheck' never pause."
:type '(choice (const :tag "never" nil) (number :tag "seconds"))
:group 'regexp-lock)
(defcustom regexp-lock-redo-size 500
"*Number of characters Regexp Lock refontifies without pause."
:type 'integer
:group 'regexp-lock)
(defcustom regexp-lock-recheck-delay 1
"*Time in seconds Regexp Lock waits before rechecking.
Rechecking is needed since refontification \(`regexp-lock-redo'\) can
not tell whether a multi-line string that matches - or does not match -
`regexp-lock-regexp-string' did so in earlier fontifications too. The
function `regexp-lock-recheck' periodically checks strings whether they
\(still\) qualify as regexp subexpressions. It does so by searching
windows for `regexp-lock-regexp-string' and requesting refontification
whenever the semantics of a string might have changed. If the value of
regexp-lock-recheck-delay is nil no rechecking is done.
In practice, the semantics of expressions change rarely. A noticeable
exception occurs when you compose a regexp spanning multiple lines and
the first match for `regexp-lock-regexp-string' does not occur on the
first lines."
:type '(choice (const :tag "never" nil) (number :tag "seconds"))
:set (lambda (symbol value)
(set-default symbol value)
(when (boundp 'regexp-lock-recheck-timer)
(when regexp-lock-recheck-timer
(cancel-timer regexp-lock-recheck-timer)
(setq regexp-lock-recheck-timer nil))
(when value
(setq regexp-lock-recheck-timer
(run-with-idle-timer value t 'regexp-lock-recheck)))))
:group 'regexp-lock)
(defcustom regexp-lock-show-priority 1000
"*Priority of overlays highlighting the regexp at point.
Regexp Lock uses this priority for overlays highlighting the regexp at
point and group numbers."
:type 'integer
:group 'regexp-lock)
(defcustom regexp-lock-show-delay 0.2
"*Time in seconds to wait before highlighting the regexp at point.
Regexp Lock waits this many seconds before highlighting the regexp at
point and any group numbers. A value of nil means that no such
highlighting is performed."
:type '(choice (const :tag "never" nil) (number :tag "seconds"))
:set (lambda (symbol value)
(set-default symbol value)
(when (boundp 'regexp-lock-show-timer)
(when regexp-lock-show-timer
(cancel-timer regexp-lock-show-timer))
(setq regexp-lock-show-timer nil)
(when value
(setq regexp-lock-show-timer
(run-with-idle-timer value t 'regexp-lock-show)))))
:group 'regexp-lock)
(defcustom regexp-lock-match-before-group "{"
"*String displayed before group number of matching expression.
Matching the regexp at point has Regexp Lock display group numbers of
corresponding regexp subexpressions. These numbers are indicated with
the help of overlays appearing before and after the match. If two or
more subexpressions match at the same position, you may discriminate
them more easily by displaying this string before any group number."
:type 'string
:group 'regexp-lock)
(defcustom regexp-lock-match-after-group "}"
"*String displayed after group number of matching expression.
Matching the regexp at point has Regexp Lock display group numbers of
corresponding regexp subexpressions. These numbers are indicated with
the help of overlays appearing before and after the match. If two or
more subexpressions match at the same position, you may discriminate
them more easily by displaying this string after any group number."
:type 'string
:group 'regexp-lock)
(defcustom regexp-lock-hook nil
"Hook run after Regexp Lock has been turned on or off."
:type 'hook
:group 'regexp-lock)
;; _____________________________________________________________________________
;;
;;; Mode definitions
;; _____________________________________________________________________________
;;
(define-minor-mode regexp-lock-mode
"Toggle Regexp Lock.
Regexp Lock is a minor mode for highlighting regular expressions in
Emacs Lisp mode. When activated, it has font-lock modify syntactic
properties and appearance of regexp constituents as follows:
- Ordinary brackets, parentheses, and semicolons are assigned the
`symbol' syntax-table property. As a consequence, `forward-sexp' and
`backward-sexp' within strings will skip parenthesized groups and
alternatives in a more intuitive way. `blink-matching-open' and
`show-paren-mode' will not falsely indicate mismatching parens.
- Brackets delimiting character alternatives are highlighted with
`font-lock-regexp-grouping-construct' face. Special parentheses and
brackets that don't match are signaled with `font-lock-warning-face'.
- Highlight the regular expression at point with `regexp-lock-regexp'
face. Also overlay the backslashes used to escape subgroup delimiting
parens with the associated group number. Group numbers are displayed
with `regexp-lock-group' face. These overlays are installed whenever
`point' is immediately before or after a string or subgroup delimiter
of the regexp at point.
The commands \\[regexp-lock-match-next] and \\[regexp-lock-match-prev]
can be used to highlight the next respectively previous expression
matching the regexp at point in another window. These commands use
`eval' to evaluate the regexp at point. For the current match they
highlight:
- The entire match `(match-string 0)' with `regexp-lock-match' face.
- Group numbers corresponding to subgroup matches are highlighted with
`regexp-lock-match-group' face. In addition, the strings specified by
`regexp-lock-match-before-group' and `regexp-lock-match-after-group'
are used to separate group numbers.
Matches before and after the current match are highlighted with
`regexp-lock-match-other' face. If necessary, Regexp Lock splits the
selected window in order to display matches. Initially, matches are
shown for the buffer containing the regexp at point. Matches for any
other buffer can be shown by switching to that buffer in the window
displaying matches.
Finally, Regexp Lock provides a function `regexp-lock-increment' which
permits to in-/decrement arguments of `match-beginning' or `match-end'
within the region.
Caveats:
- Regexp Lock uses a number of heuristics to detect regexps. Hence you
will occasionally see ordinary strings highlighted as regexps as well
as regexps highlighted as ordinary strings. In some cases customizing
the variable `regexp-lock-regexp-string' might help.
- Regexp Lock analyzes regular expressions literally. Hence if you
write something like
\(defvar foo \"\\\\(\") \(defvar bar (concat foo \"bar\\\\)\"))
Regexp Lock is not able to indicate group numbers correctly and will
additionally issue two warnings.
- Regexp Lock expects that a regexp produced by `regexp-opt' is
contained in a grouping construct iff the second argument of
regexp-opt is present and does not equal one of the character
sequences `nil' or `()'.
- Regexp Lock does not recognize expressions constructed by `rx' or
`sregex'.
- Regexp Lock consumes processor resources. On battery-powered systems
you should turn it off whenever you don't need it."
:lighter regexp-lock-minor-mode-string
:group 'regexp-lock
:keymap '(("\C-c(" . regexp-lock-match-next)
("\C-c)" . regexp-lock-match-prev)
("\C-c#" . regexp-lock-increment))
(if regexp-lock-mode
(regexp-lock-activate)
(regexp-lock-deactivate))
(run-hooks 'regexp-lock-hook))
(defun turn-on-regexp-lock-mode ()
"Unequivocally turn on `regexp-lock-mode'."
(interactive)
(regexp-lock-mode 1))
;; _____________________________________________________________________________
;;
;;; Local definitions
;; _____________________________________________________________________________
;;
(defvar regexp-lock-redo t
"When non-nil refontify this buffer.")
(defvar regexp-lock-redo-timer nil
"Idle timer for `regexp-lock-redo'.")
(defvar regexp-lock-recheck t
"When non-nil recheck this buffer.")
(defvar regexp-lock-recheck-timer nil
"Idle timer for `regexp-lock-recheck'.")
(defvar regexp-lock-overlays nil
"Overlays used by `regexp-lock-show'.")
(defvar regexp-lock-show-timer nil
"Idle timer for `regexp-lock-show'.")
(defvar regexp-lock-match-regexp nil
"`regexp-lock-match' searches for this regexp.")
(defvar regexp-lock-match-window nil
"`regexp-lock-match' display matches in this window.")
(defvar regexp-lock-match-buffer nil
"`regexp-lock-match-window' displays this buffer.")
(defvar regexp-lock-match-overlays nil
"Overlays that highlight matches in `regexp-lock-match-window'.")
(defvar regexp-lock-match-from (make-marker)
"Marker for match begin in `regexp-lock-match-buffer'.")
(defvar regexp-lock-match-to (make-marker)
"Marker for match end in `regexp-lock-match-buffer'.")
(eval-when-compile
(defmacro save-regexp-lock (&rest body)
"Eval BODY with match-data, excursion, restrictions saved, buffer widened."
`(save-match-data
(save-excursion
(save-restriction
(widen)
(progn ,@body)))))
(put 'save-regexp-lock 'lisp-indent-function 0)
(def-edebug-spec save-regexp-lock let)
(defmacro with-regexp-lock (&rest body)
"Eval BODY, preserving current buffer's modified and undo states."
(let ((modified (make-symbol "modified")))
`(let ((,modified (buffer-modified-p))
(buffer-undo-list t)
(inhibit-read-only t)
(inhibit-point-motion-hooks t)
(inhibit-modification-hooks t)
deactivate-mark
buffer-file-name
buffer-file-truename)
(unwind-protect
(progn ,@body)
(unless ,modified
(restore-buffer-modified-p nil))))))
(put 'with-regexp-lock 'lisp-indent-function 0)
(def-edebug-spec with-regexp-lock let))
(defsubst regexp-lock-string-face-p (face)
"Return t when character at `point' has `font-lock-string-face' face property."
(or (and (listp face)
(memq 'font-lock-string-face face))
(eq face 'font-lock-string-face)))
(defsubst regexp-lock-syntactic-face-p (face)
"Return t when face property at `point' indicates syntactic context.
More precisely, return t when character at point has one of
`font-lock-string-face', `font-lock-comment-face', or
`font-lock-doc-face' face property."
(or (and (listp face)
(or (memq 'font-lock-string-face face)
(memq 'font-lock-comment-face face)
(memq 'font-lock-doc-face face)))
(memq face '(font-lock-string-face
font-lock-comment-face
font-lock-doc-face))))
;; the following function is commented out in font-lock.el
(defun remove-text-property (start end property &optional object)
"Remove a property from text from START to END.
Argument PROPERTY is the property to remove.
Optional argument OBJECT is the string or buffer containing the text.
Return t if the property was actually removed, nil otherwise."
(remove-text-properties start end (list property) object))
;; the following function is commented out in font-lock.el
(defun remove-single-text-property (start end prop value &optional object)
"Remove a specific property value from text from START to END.
Arguments PROP and VALUE specify the property and value to remove. The
resulting property values are not equal to VALUE nor lists containing VALUE.
Optional argument OBJECT is the string or buffer containing the text."
(let ((start (text-property-not-all start end prop nil object)) next prev)
(while start
(setq next (next-single-property-change start prop object end)
prev (get-text-property start prop object))
(cond ((and (symbolp prev) (eq value prev))
(remove-text-property start next prop object))
((and (listp prev) (memq value prev))
(let ((new (delq value prev)))
(cond ((null new)
(remove-text-property start next prop object))
((= (length new) 1)
(put-text-property start next prop (car new) object))
(t
(put-text-property start next prop new object))))))
(setq start (text-property-not-all next end prop nil object)))))
;; _____________________________________________________________________________
;;
;;; Activate / Deactivate
;; _____________________________________________________________________________
;;
(defun regexp-lock-activate ()
"Activate Regexp Lock in current buffer."
(if (not (memq major-mode
'(emacs-lisp-mode lisp-mode lisp-interaction-mode reb-mode)))
(error "Regexp Lock can be used in Lisp modes only")
;; turn on font-lock if necessary and integrate ourselves
(unless font-lock-mode (font-lock-mode 1))
(set (make-local-variable 'font-lock-extra-managed-props)
(append font-lock-extra-managed-props
(list 'syntax-table 'regexp-lock)))
(font-lock-add-keywords nil '(regexp-lock-fontify . nil) t)
(font-lock-unfontify-buffer)
(save-restriction
(widen)
(with-regexp-lock
(remove-text-properties (point-min) (point-max) '(fontified t))))
;; syntax properties
(set (make-local-variable 'parse-sexp-lookup-properties) t)
;; hooks
(add-hook 'after-change-functions 'regexp-lock-after-change nil t)
(add-hook 'window-scroll-functions 'regexp-lock-window-redo t t)
(add-hook 'window-size-change-functions 'regexp-lock-frame-redo)
(add-hook 'change-major-mode-hook 'regexp-lock-deactivate nil t)
;; redo-timer
(when regexp-lock-redo-timer
(cancel-timer regexp-lock-redo-timer)
(setq regexp-lock-redo-timer nil))
(when regexp-lock-redo-delay
(setq regexp-lock-redo-timer
(run-with-idle-timer regexp-lock-redo-delay t 'regexp-lock-redo)))
(set (make-local-variable 'regexp-lock-redo) nil)
;; recheck-timer
(when regexp-lock-recheck-timer
(cancel-timer regexp-lock-recheck-timer)
(setq regexp-lock-recheck-timer nil))
(when regexp-lock-recheck-delay
(setq regexp-lock-recheck-timer
(run-with-idle-timer
regexp-lock-recheck-delay t 'regexp-lock-recheck)))
(set (make-local-variable 'regexp-lock-recheck) nil)
;; show-timer
(when regexp-lock-show-timer
(cancel-timer regexp-lock-show-timer)
(setq regexp-lock-show-timer nil))
(when regexp-lock-show-delay
(setq regexp-lock-show-timer
(run-with-idle-timer regexp-lock-show-delay t 'regexp-lock-show)))))
(defun regexp-lock-deactivate ()
"Deactivate Regexp Lock in current buffer."
;; syntax properties
(setq parse-sexp-lookup-properties nil)
;; local hooks
(remove-hook 'after-change-functions 'regexp-lock-after-change)
(remove-hook 'window-scroll-functions 'regexp-lock-window-redo)
(remove-hook 'change-major-mode-hook 'regexp-lock-deactivate)
(remove-hook 'pre-command-hook 'regexp-lock-match-pre-command)
;; redo
(with-regexp-lock
(remove-text-properties (point-min) (point-max) '(regexp-lock-redo nil)))
;; font lock
(font-lock-unfontify-buffer)
(setq font-lock-extra-managed-props
(delq 'syntax-table
(delq 'regexp-lock
font-lock-extra-managed-props)))
(font-lock-remove-keywords nil '(regexp-lock-fontify . nil))
(save-restriction
(widen)
(with-regexp-lock
(remove-text-properties (point-min) (point-max) '(fontified t))))
(unless (catch 'found
(dolist (buffer (buffer-list))
(when (with-current-buffer buffer regexp-lock-mode)
(throw 'found t))))
;; markers
(set-marker regexp-lock-match-from nil)
(set-marker regexp-lock-match-to nil)
;; global hook
(remove-hook 'window-size-change-functions 'regexp-lock-frame-redo)
;; redo-timer
(when regexp-lock-redo-timer
(cancel-timer regexp-lock-redo-timer)
(setq regexp-lock-redo-timer nil))
;; recheck-timer
(when regexp-lock-recheck-timer
(cancel-timer regexp-lock-recheck-timer)
(setq regexp-lock-recheck-timer nil))
;; show-timer
(when regexp-lock-show-timer
(cancel-timer regexp-lock-show-timer)
(setq regexp-lock-show-timer nil))))
;; _____________________________________________________________________________
;;
;;; Text Properties
;; _____________________________________________________________________________
;;
(defun regexp-lock-after-change (start end old-len)
"Mark text after buffer change to trigger `regexp-lock-redo'."
(when regexp-lock-mode
(with-regexp-lock
(save-excursion
(goto-char start)
(if (save-match-data
(save-excursion
(beginning-of-line)
(re-search-forward
regexp-lock-regexp-string (max end (line-end-position)) t)))
(put-text-property
(line-beginning-position) (min (max end (1+ start)) (point-max))
'regexp-lock-redo 2)
(put-text-property
(line-beginning-position) (min (max end (1+ start)) (point-max))
'regexp-lock-redo t))
(setq regexp-lock-redo t)))))
(defun regexp-lock-window-redo (window start)
"Mark text after window scroll to trigger `regexp-lock-redo'."
(with-current-buffer (window-buffer window)
(when regexp-lock-mode
(setq regexp-lock-redo t))))
(defun regexp-lock-frame-redo (frame)
"Mark text after window size change to trigger `regexp-lock-redo'."
;; Use frame-first-window since selected-window may be on a different frame.
(with-selected-window (frame-first-window frame)
(dolist (window (window-list frame 'nominibuf))
(with-current-buffer (window-buffer window)
(when regexp-lock-mode
(setq regexp-lock-redo t))))))
(defun regexp-lock-redo ()
"Refontify with Regexp Lock.
Currently this operates on all windows of the selected frame."
(catch 'input
(let ((current-buffer (current-buffer))
(current-point (point))
(current-point-min (point-min))
(current-point-max (point-max)))
(dolist (window (window-list nil 'nominibuf))
(with-current-buffer (window-buffer window)
(when (and regexp-lock-mode regexp-lock-redo font-lock-mode)
(let ((window-start (window-start window))
(window-end (window-end window))
(parse-sexp-ignore-comments t))
(save-regexp-lock
(let* ((bod (save-excursion
;; bod is the last beginning-of-defun
;; preceding start of window or point-min
(goto-char window-start)
(or (condition-case nil
(progn
(beginning-of-defun)
(line-beginning-position))
(error (point-min)))
(point-min))))
(eod (save-excursion
;; eod is the first end-of-defun following
;; end of window or point-max
(goto-char window-end)
(or (condition-case nil
(progn
(beginning-of-defun -1)
(max window-end
(line-beginning-position)))
(error (point-max)))
(point-max))))
;; from is the first redo position between bod
;; and eod
(from (min (or (text-property-any
bod eod 'regexp-lock-redo t)
eod)
(or (text-property-any
bod eod 'fontified nil)
eod)))
to)
(when (and from (< from eod))
(save-excursion
(goto-char from)
(setq from (line-beginning-position)))
;; adjust from
(when (or (< from bod)
(and (> from bod)
(not (get-text-property
(1- from) 'fontified))))
;; refontify from bod
(setq from bod))
;; initialize to
(when (or (< from window-end)
(not (equal (get-text-property
(1- from) 'regexp-lock)
(get-text-property
from 'regexp-lock))))
(setq to (min (save-excursion
(goto-char
(+ from regexp-lock-redo-size))
(line-beginning-position 2))
eod))
;; fontify
(while (and (< from to)
(or (not regexp-lock-pause)
(save-excursion
(with-current-buffer current-buffer
(save-restriction
(goto-char current-point)
(narrow-to-region
current-point-min
current-point-max)
(sit-for regexp-lock-pause))))
(throw 'input t)))
(with-regexp-lock
;; record the following two properties _now_
;; since font-lock may fontify past to
(let ((fontified-at-to
(get-text-property to 'fontified))
(lock-at-to
(get-text-property to 'regexp-lock)))
(put-text-property from to 'fontified t)
(if jit-lock-mode
;; as jit-lock-fontify-now
(condition-case err
(run-hook-with-args
'jit-lock-functions from to)
(quit (put-text-property
from to 'fontified nil)
(funcall
'signal (car err) (cdr err))))
;; plain font-lock-fontify-region
(font-lock-fontify-region from to))
(remove-text-properties
from to '(regexp-lock-redo nil))
(setq from to)
(when (and (< to eod)
(or (not fontified-at-to)
(not (equal (get-text-property
(1- to) 'regexp-lock)
lock-at-to))))
(put-text-property
to (min (1+ to) (point-max))
'regexp-lock-redo t)
(setq to (min (save-excursion
(goto-char
(+ to regexp-lock-redo-size))
(line-beginning-position 2))
eod))))))))))
;; keep the following always _within_ the outermost
;; let to avoid that other idle timers get confused
(timer-activate-when-idle regexp-lock-show-timer t)
(setq regexp-lock-redo nil)
(setq regexp-lock-recheck t))))
(or (not regexp-lock-pause)
(sit-for regexp-lock-pause)
(throw 'input t))))))
(defsubst regexp-lock-set-redo (from to)
"Set `regexp-lock-redo' from `regexp-lock-recheck'.
This sets the `regexp-lock-redo' text-property at FROM as well as the
buffer-local value of `regexp-lock-redo' to t. Values are set if a
match for `regexp-lock-regexp-string' is found before TO and the
`regexp-lock' text-property at FROM is not set or no match before TO
exists and the `regexp-lock' text-property is set."
(if (re-search-forward regexp-lock-regexp-string to 'to)
;; match for regexp-lock-regexp-string
(unless (get-text-property from 'regexp-lock)
;; regexp-lock not set, redo
(with-regexp-lock
(put-text-property from (1+ from) 'regexp-lock-redo t))
(setq regexp-lock-redo t))
;; no match for regexp-lock-regexp-string
(when (get-text-property from 'regexp-lock)
;; regexp-lock set, redo
(with-regexp-lock
(put-text-property from (1+ from) 'regexp-lock-redo t))
(setq regexp-lock-redo t))))
(defun regexp-lock-recheck ()
"Recheck windows with Regexp Lock.
Currently this operates on all windows of the selected frame."
(catch 'input
(let ((current-buffer (current-buffer))
(current-point (point))
(current-point-min (point-min))
(current-point-max (point-max)))
(dolist (window (window-list nil 'nominibuf))
(with-current-buffer (window-buffer window)
(when (and regexp-lock-mode regexp-lock-recheck font-lock-mode)
(let ((window-start (window-start window))
(window-end (window-end window))
(parse-sexp-ignore-comments t))
(save-regexp-lock
(let* ((from (save-excursion
;; from is the last beginning-of-defun
;; preceding start of window or point-min
(goto-char window-start)
(or (condition-case nil
(progn
(beginning-of-defun)
(line-beginning-position))
(error (point-min)))
(point-min))))
to face)
;; check iff from has been already fontified
(when (get-text-property from 'fontified)
(goto-char from)
(while (re-search-forward "\\(\"\\)\
\\|(\\(\\(?:map\\)?concat\\)\\>\
\\|(\\(re-search-\\(?:for\\|back\\)ward\\|looking-\\(?:at\\|back\\)\\|string-match\\|replace-regexp-in-string\
\\|message\\|error\\|skip-\\(?:syntax\\|chars\\)-\\(?:for\\|back\\)ward\\|search-\\(?:for\\|back\\)ward\\)\\>"
window-end 'window-end)
(setq face (get-text-property
(or (match-end 1) (match-beginning 0))
'face))
(cond
((match-beginning 1)
;; double-quote
(cond
((and (regexp-lock-string-face-p face)
(save-excursion
(condition-case nil
(progn
(setq from (match-beginning 1))
(goto-char from)
(forward-sexp)
(setq to (point)))
(error nil))))
(regexp-lock-set-redo from to)
(goto-char (min to window-end)))
((and (or (and (listp face)
(memq 'font-lock-doc-face face))
(eq 'font-lock-doc-face face))
(save-excursion
(condition-case nil
(progn
(goto-char (match-beginning 1))
(forward-sexp)
(setq to (point)))
(error nil))))
;; doc-string, skip
(goto-char (min to window-end)))))
((match-beginning 2)
;; concat, mapconcat
(when (and (not (regexp-lock-syntactic-face-p face))
(save-excursion
(condition-case nil
(progn
(setq from (match-beginning 0))
(goto-char from)
(forward-sexp)
(setq to (point)))
(error nil)))
(goto-char from))
(regexp-lock-set-redo from to)
(goto-char (min to window-end))))
((match-beginning 3)
;; re-search- / looking- / string-match /
;; replace-regexp-in-string /
;; message / error / search- / skip-syntax- /
;; skip-chars-, skip
(if (and (not (regexp-lock-syntactic-face-p face))
(save-excursion
(condition-case nil
(progn
(goto-char (match-beginning 0))
(forward-sexp)
(setq to (point)))
(error nil))))
(goto-char (min to window-end))
(goto-char (min (point) window-end)))))))
(setq regexp-lock-recheck nil)
(when regexp-lock-redo
;; activate regexp-lock-redo-timer
(timer-activate-when-idle
regexp-lock-redo-timer t)))))))))
(or (not regexp-lock-pause)
(sit-for regexp-lock-pause)
(throw 'input t))))
(defun regexp-lock-fontify (bound)
"Fontify region from `point' to BOUND."
(let ((lock (unless (= (point) (point-min))
(get-text-property (1- (point)) 'regexp-lock)))
;; `lock' - the `regexp-lock' text property - is interpreted as:
;; nil - no regexp around point (nil is not stored as text property)
;; 0 - the following sexp is a regexp
;; 1 - within a regexp-string that is not argument of a `concat'
;; >= 2 - within a `concat' that has at least one regexp argument
;; within a character alternative values are negative
(from (point))
(parse-sexp-ignore-comments t)
to face)
(while (< (point) bound)
(catch 'lock
(if lock
(while (re-search-forward
"\\(^\\s(\\)\\|\\(\"\\)\\|\\(?:\\\\\\\\\\)\\(?:\\(?:\\\\\\\\\\)\\|\\([()]\\)\\|\\(|\\)\\|\\(\\[\\)\\|\\(\\]\\)\\)\
\\|\\(\\\\[][()]\\)\\|\\(\\[:[a-zA-Z]+:\\]\\)\\|\\(\\[\\)\\|\\(\\]\\)\\|\\(;\\)\\|\\((\\)\\|\\()\\)\\|`\\(\\sw\\sw+\\)'" bound 'bound)
(setq face (get-text-property (1- (point)) 'face))
(cond
((match-beginning 1)
;; paren in column zero, throw
(put-text-property from (match-beginning 1) 'regexp-lock lock)
(setq lock nil)
(throw 'lock nil))
((match-beginning 2)
;; double-quote, ignore for lock not in {-1,0,1}
(cond
((zerop lock)
;; start new regexp-string
(put-text-property from (match-beginning 2) 'regexp-lock 0)
(setq from (match-beginning 2))
(goto-char (1+ from))
(setq lock 1))
((and (or (= lock 1) (= lock -1))
;; the following skips adjacent double-quotes as in
;; "string1""string2" which should not do much harm
(regexp-lock-string-face-p face)
(or (= (point) bound) ; fails with escaped `"' at eob
(not (regexp-lock-string-face-p
(get-text-property (point) 'face)))))
;; terminate current regexp-string
(put-text-property from (point) 'regexp-lock lock)
(when (= lock -1)
;; unclosed character alternative, warn
(put-text-property
(1- (point)) (point) 'face 'font-lock-warning-face))
(setq lock nil)
(throw 'lock nil))))
((and (match-beginning 12)
(not (regexp-lock-syntactic-face-p face)))
;; non-syntactic left paren, expects lock not in {-1,1}
(put-text-property from (match-beginning 12) 'regexp-lock lock)
(setq from (match-beginning 12))
(cond
((>= lock 2) (setq lock (1+ lock)))
((<= lock -2) (setq lock (1- lock)))
((zerop lock) (setq lock 2))
(t (setq lock nil) ; looses
(throw 'lock nil))))
((and (match-beginning 13)
(not (regexp-lock-syntactic-face-p face)))
;; non-syntactic right paren, expects lock not in {-1,1}
(put-text-property from (match-end 13) 'regexp-lock lock)
(setq from (match-end 13))
(cond
((> lock 2) (setq lock (1- lock)))
((< lock -2) (setq lock (1+ lock)))
(t (when (= lock -2)
;; unclosed character alternative, warn
(put-text-property
(1- (point)) (point) 'face 'font-lock-warning-face))
(setq lock nil) ; end of sexp or looser
(throw 'lock nil))))
((regexp-lock-string-face-p face)
;; matches below are valid within strings only
(cond
((match-beginning 3) ; \\( or \\)
(when (< lock 0)
;; within character alternative, set symbol syntax
(put-text-property (1- (point)) (point) 'syntax-table '(3))
;; remove faces that are silly here
(remove-single-text-property
(match-beginning 0) (1- (match-end 0))
'face 'font-lock-regexp-backslash)
(remove-single-text-property
(1- (match-end 0)) (match-end 0)
'face 'font-lock-regexp-grouping-construct)))
((match-beginning 4) ; \\|
(when (< lock 0)
;; within character alternative remove regexp-lock faces
(remove-single-text-property
(match-beginning 0) (1- (match-end 0))
'face 'font-lock-regexp-backslash)
(remove-single-text-property
(1- (match-end 0)) (match-end 0)
'face 'font-lock-regexp-grouping-construct)))
((match-beginning 5) ; \\[
(let ((face (get-text-property (point) 'face)))
(when (and (listp face)
(memq 'font-lock-constant-face face))
;; remove font-lock-constant-face
(remove-single-text-property
(point) (next-single-property-change
(point) 'face nil (line-end-position))
'face 'font-lock-constant-face)))
(if (< lock 0)
;; within character alternative, reread bracket
(goto-char (1- (point)))
;; not within character alternative, set symbol syntax
(put-text-property
(1- (point)) (point) 'syntax-table '(3))))
((match-beginning 6) ; \\]
(if (< lock 0)
;; within character alternative, reread bracket
(goto-char (1- (point)))
;; not within character alternative, set symbol syntax
(put-text-property
(1- (point)) (point) 'syntax-table '(3))))
((match-beginning 7) ; escaped parenthesis or bracket
;; set symbol syntax for backslash and reread paren
(put-text-property
(match-beginning 0) (1+ (match-beginning 0))
'syntax-table '(3))
(goto-char (1+ (match-beginning 0))))
((match-beginning 8))
;; POSIX character class, skip
((match-beginning 9) ; [
(let ((face (get-text-property (point) 'face)))
(when (and (listp face)
(memq 'font-lock-constant-face face))
;; remove font-lock-constant-face
(remove-single-text-property
(point) (next-single-property-change
(point) 'face nil (line-end-position))
'face 'font-lock-constant-face)))
(if (< lock 0)
;; within character alternative, set symbol syntax
(put-text-property
(1- (point)) (point) 'syntax-table '(3))
;; start new character alternative
(put-text-property from (1- (point)) 'regexp-lock lock)
(setq from (1- (point)))
(setq lock (- lock))
(font-lock-prepend-text-property
(match-beginning 9) (match-end 9)
'face 'font-lock-regexp-grouping-construct)
(when (looking-at "\\(?:\\\\?\\^\\)?\\\\?\\(\\]\\)")
;; non-special right bracket, set symbol syntax
(put-text-property
(match-beginning 1) (match-end 1) 'syntax-table '(3))
(goto-char (match-end 1)))))
((match-beginning 10) ; ]
(if (> lock 0)
;; not within character alternative, warn
(font-lock-prepend-text-property
(match-beginning 10) (match-end 10)
'face 'font-lock-warning-face)
;; terminate alternative
(font-lock-prepend-text-property
(match-beginning 10) (match-end 10)
'face 'font-lock-regexp-grouping-construct)
(put-text-property from (point) 'regexp-lock lock)
(setq from (point))
(setq lock (- lock))))
((or (match-beginning 11)
(match-beginning 12)
(match-beginning 13)) ; (;), set symbol syntax
(put-text-property (1- (point)) (point) 'syntax-table '(3)))
((match-beginning 14) ; `..', remove constant face property
(remove-single-text-property
(match-beginning 0) (match-end 0)
'face 'font-lock-constant-face))))))
;; no lock
(while (re-search-forward "\\(\"\\)\
\\|(\\(re-search-\\(?:for\\|back\\)ward\\|looking-\\(?:at\\|back\\)\\|string-match\\|replace-regexp-in-string\\)\\>\
\\|(\\(\\(?:map\\)?concat\\)\\>\
\\|(\\(message\\|error\\|skip-\\(?:syntax\\|chars\\)-\\(?:for\\|back\\)ward\\|search-\\(?:for\\|back\\)ward\\)\\>"
bound 'bound)
(setq face (get-text-property
(or (match-end 1) (match-beginning 0)) 'face))
(cond
((match-beginning 1)
;; double-quote, search for `regexp-lock-regexp-string'
(cond
((and (regexp-lock-string-face-p face)
(save-excursion
(condition-case nil
(progn
(setq from (match-beginning 1))
(goto-char from)
(forward-sexp)
(setq to (point)))
(error nil))))
(if (re-search-forward regexp-lock-regexp-string to t)
;; plain string matching `regexp-lock-regexp-string'
(progn
(setq lock 1)
(goto-char (1+ from))
(throw 'lock nil))
;; plain string that does not match, skip
(goto-char (min to bound))))
((and (or (and (listp face) (memq 'font-lock-doc-face face))
(eq 'font-lock-doc-face face))
(save-excursion
(condition-case nil
(progn
(goto-char (match-beginning 1))
(forward-sexp)
(setq to (point)))
(error nil))))
;; doc-string, skip
(goto-char (min to bound)))))
((match-beginning 2)
;; re-search- / looking- / string-match / replace-regexp-in-string
(unless (regexp-lock-syntactic-face-p face)
(setq from (match-end 2))
(setq lock 0)
(throw 'lock nil)))
((match-beginning 3)
;; concat / mapconcat, search arguments for
;; `regexp-lock-regexp-string'
(if (and (not (regexp-lock-syntactic-face-p face))
(save-excursion
(condition-case nil
(progn
(setq from (match-beginning 0))
(goto-char from)
(forward-sexp)
(setq to (point)))
(error nil)))
(goto-char from)
(re-search-forward
(concat regexp-lock-regexp-string
"\\|regexp-opt") to 'to))
(progn
(setq lock 2)
(goto-char (1+ from))
(throw 'lock nil))
(goto-char (min (point) bound))))
((match-beginning 4)
;; message / error / search- / skip-syntax- / skip-chars-, skip
(if (and (not (regexp-lock-syntactic-face-p face))
(save-excursion
(condition-case nil
(progn
(goto-char (match-beginning 0))
(forward-sexp)
(setq to (point)))
(error nil))))
(goto-char (min to bound))
(goto-char (min (point) bound)))))))))
(when lock (put-text-property from bound 'regexp-lock lock))))
;; _____________________________________________________________________________
;;
;;; Overlays
;; _____________________________________________________________________________
;;
(defun regexp-lock-show ()
"Display numbers of regular expression groups.
Groups considered are subexpressions enclosed by escaped parentheses
`\\(' and `\\)'. Shy groups are not counted. Group numbers overlay one
or both backslashes of any `\\(' and `\\)' of the same regexp with the
number of the group. Overlays are highlighted whenever `point' is
before the left or after the right parenthesis of an `\\(' or `\\)'.
Hence the group enclosed by `\1(...\1)', for example, represents the
subexpression matching `(match-string 1)'. Overlays are also shown when
`point' is before a double-quote beginning, or after a double-quote
terminating a string that is part of the regular expression.
Group numbers are displayed whenever Emacs becomes idle after a delay of
`regexp-lock-show-delay' seconds. Group numbers are highlighted with
`regexp-lock-group' face."
(when regexp-lock-overlays
(dolist (overlay regexp-lock-overlays)
(delete-overlay overlay))
(setq regexp-lock-overlays nil))
(when (and regexp-lock-mode
(not (eq (selected-window) regexp-lock-match-window))
(or (and (< 2 (point)) ; \\^(
(< (point) (point-max))
(char-equal (char-after) ?\( )
(get-text-property (1- (point)) 'regexp-lock)
(> (get-text-property (1- (point)) 'regexp-lock) 0)
(char-equal (char-before) ?\\ )
(char-equal (char-before (1- (point))) ?\\ ))
(and (< 3 (point)) ; \\)^
(char-equal (char-before) ?\) )
(get-text-property (1- (point)) 'regexp-lock)
(> (get-text-property (1- (point)) 'regexp-lock) 0)
(char-equal (char-before (1- (point))) ?\\ )
(char-equal (char-before (- (point) 2)) ?\\ ))
(and (< (point) (point-max)) ; ^"
(char-equal (char-after) ?\" )
(get-text-property (point) 'regexp-lock)
(regexp-lock-string-face-p
(get-text-property (point) 'face))
(or (= (point) (point-min))
(not (regexp-lock-string-face-p
(get-text-property (1- (point)) 'face)))))
(and (< 3 (point)) ; "^
(char-equal (char-before) ?\" )
(get-text-property (1- (point)) 'regexp-lock)
(regexp-lock-string-face-p
(get-text-property (1- (point)) 'face))
(or (= (point) (point-max))
(not (regexp-lock-string-face-p
(get-text-property (point) 'face)))))))
(save-match-data
(save-excursion
(let* ((at (point)) (groups nil) (number 0) (total 0)
(from at) (to at)
(parse-sexp-ignore-comments t))
;; search beginning and end, tedious
(while (and (> from (point-min))
(get-text-property (1- from) 'regexp-lock)
(not (zerop (get-text-property (1- from) 'regexp-lock)))
(setq from (previous-single-property-change
(point) 'regexp-lock nil (point-min)))
(goto-char from)))
(goto-char at)
(while (and (< to (point-max))
(get-text-property to 'regexp-lock)
(setq to (next-single-property-change
(point) 'regexp-lock nil (point-max)))
(goto-char to)))
;; make overlay for group zero
(let ((overlay (make-overlay from to)))
(overlay-put overlay 'face 'regexp-lock-regexp)
(overlay-put overlay 'window (selected-window))
(overlay-put overlay 'cursor t)
(overlay-put overlay 'priority regexp-lock-show-priority)
(setq regexp-lock-overlays (cons overlay regexp-lock-overlays)))
;; using a fixed-size vector here would avoid consing but
;; introduce an upper limit on the number of groupings
(goto-char from)
(while (re-search-forward "\\(?:\\\\\\\\\\)\\(?:\\(?:\\\\\\\\\\)\\|\\((\\(\\?:\\)?\\)\\|\\()\\)\\)\\|\\(regexp-opt\\)" to t)
(cond
((and (match-beginning 4) ; (regexp-opt ...)
(not (regexp-lock-syntactic-face-p (match-beginning 4))))
(save-match-data
(let (at-too) ; Re-search from here.
(when (save-excursion
(goto-char (match-end 4))
(condition-case nil
(progn
(forward-sexp)
(forward-comment (buffer-size))
(setq at-too (point))
;; Anything but `nil' and `()' counts as non-nil.
(when (looking-at "\\(?:nil\\|()\\)")
(goto-char (match-end 0))
(forward-comment (buffer-size)))
(and (looking-at "[^)]")))
(error nil)))
(setq total (1+ total)))
(when at-too (goto-char at-too)))))
((or (not (regexp-lock-string-face-p
(get-text-property (1- (point)) 'face)))
(< (get-text-property (1- (point)) 'regexp-lock) 0)))
((match-beginning 2) ; \\(?:
(setq groups (cons 0 groups)))
((match-beginning 1) ; \\(
(setq number (1+ total))
(setq total (1+ total))
(let* ((number-string (number-to-string number))
(length (min (length number-string) 2))
(overlay (make-overlay
(- (match-beginning 1) length)
(match-beginning 1))))
(overlay-put overlay 'display
(propertize number-string 'face 'regexp-lock-group))
(overlay-put overlay 'window (selected-window))
(overlay-put overlay 'cursor t)
(overlay-put overlay 'priority regexp-lock-show-priority)
(setq regexp-lock-overlays (cons overlay regexp-lock-overlays)))
(setq groups (cons number groups)))
((match-beginning 3) ; \\)
(cond
(groups
(setq number (car groups))
(unless (zerop number)
(let* ((number-string (number-to-string number))
(length (min (length number-string) 2))
(overlay (make-overlay
(- (match-beginning 3) length)
(match-beginning 3))))
(overlay-put overlay 'display
(propertize
number-string 'face 'regexp-lock-group))
(overlay-put overlay 'window (selected-window))
(overlay-put overlay 'cursor t)
(overlay-put overlay 'priority regexp-lock-show-priority)
(setq regexp-lock-overlays
(cons overlay regexp-lock-overlays))))
(setq groups (cdr groups)))
(t ; no open group, warn
(let ((overlay (make-overlay (1- (match-end 3)) (match-end 3))))
(overlay-put overlay 'face font-lock-warning-face)
(overlay-put overlay 'window (selected-window))
(overlay-put overlay 'priority regexp-lock-show-priority)
(setq regexp-lock-overlays
(cons overlay regexp-lock-overlays))))))))
(when groups
;; unclosed group, warn
(let ((overlay (make-overlay (1- to) to)))
(overlay-put overlay 'face font-lock-warning-face)
(overlay-put overlay 'window (selected-window))
(overlay-put overlay 'priority regexp-lock-show-priority)
(setq regexp-lock-overlays
(cons overlay regexp-lock-overlays)))))))))
;; _____________________________________________________________________________
;;
;;; Matching
;; _____________________________________________________________________________
;;
(defun regexp-lock-match-pre-command ()
"Remove match overlays."
(when regexp-lock-match-overlays
(dolist (overlay regexp-lock-match-overlays)
(delete-overlay overlay))
(setq regexp-lock-match-overlays nil))
;; remove ourselves from pre-command-hook
(remove-hook 'pre-command-hook 'regexp-lock-match-pre-command))
(defun regexp-lock-match (direction)
"Highlight expressions matching current regexp."
(interactive)
(unless (and regexp-lock-match-regexp
(memq last-command
'(regexp-lock-match-next regexp-lock-match-prev)))
(if (or (and (< (point) (point-max))
(get-text-property (point) 'regexp-lock))
(and (> (point) (point-min))
(get-text-property (1- (point)) 'regexp-lock)))
(save-match-data
(save-excursion
(let* ((at (point)) (from at) (to at)
(parse-sexp-ignore-comments t))
;; search beginning and end, tedious
(while (and (> from (point-min))
(get-text-property (1- from) 'regexp-lock)
(not (zerop (get-text-property
(1- from) 'regexp-lock)))
(setq from (previous-single-property-change
(point) 'regexp-lock nil (point-min)))
(goto-char from)))
(goto-char at)
(while (and (< to (point-max))
(get-text-property to 'regexp-lock)
(setq to (next-single-property-change
(point) 'regexp-lock nil (point-max)))
(goto-char to)))
(save-restriction
(narrow-to-region from to)
(goto-char (point-min))
(setq regexp-lock-match-regexp
(condition-case var
(eval (read (current-buffer)))
;; display signal information
(error (message "%s" var) nil)))))))
(message "No regexp around point")))
(when regexp-lock-match-regexp
(if (and regexp-lock-match-window
(window-live-p regexp-lock-match-window)
(not (eq regexp-lock-match-window (selected-window))))
;; remember buffer
(setq regexp-lock-match-buffer (window-buffer regexp-lock-match-window))
;; unless regexp-lock-match-window is a live window different from
;; the selected one, split the selected window and make the newly
;; created one the new regexp-lock-match-window
(setq regexp-lock-match-window (split-window))
(if (and (not (eq (window-buffer regexp-lock-match-window)
regexp-lock-match-buffer))
(buffer-live-p regexp-lock-match-buffer))
(progn
;; when regexp-lock-match-buffer is a live buffer assert
;; that it is displayed in regexp-lock-match-window (make
;; sure we're not affected by Stefan's `set-window-buffer'
;; fix).
(set-window-buffer
regexp-lock-match-window regexp-lock-match-buffer)
(when (eq regexp-lock-match-window (selected-window))
(set-buffer regexp-lock-match-buffer)))
;; remember buffer
(setq regexp-lock-match-buffer
(window-buffer regexp-lock-match-window))))
(save-match-data
(save-excursion
(with-selected-window regexp-lock-match-window
;; handle direction changes in an intuitive way
(cond
((and (eq last-command 'regexp-lock-match-next)
(< direction 0)
(eq (marker-buffer regexp-lock-match-from)
regexp-lock-match-buffer))
;; use from marker
(goto-char regexp-lock-match-from))
((and (eq last-command 'regexp-lock-match-prev)
(> direction 0)
(eq (marker-buffer regexp-lock-match-to)
regexp-lock-match-buffer))
;; use to marker
(goto-char regexp-lock-match-to)))
(let ((at (point))
bound first)
(catch 'empty
(while (if (< direction 0)
(re-search-backward regexp-lock-match-regexp bound t)
(re-search-forward regexp-lock-match-regexp bound t))
(if (= (match-beginning 0) (match-end 0))
(progn
(message "Empty match ...")
(sit-for 1)
(throw 'empty nil))
(let ((overlay (make-overlay
(match-beginning 0) (match-end 0)))
(matches (cddr (match-data)))
(index 1))
(setq regexp-lock-match-overlays
(cons overlay regexp-lock-match-overlays))
(overlay-put overlay 'face
(if first
'regexp-lock-match-other
'regexp-lock-match))
(overlay-put overlay 'window regexp-lock-match-window)
(unless first
(setq first (point))
(set-marker regexp-lock-match-from (match-beginning 0))
(set-marker regexp-lock-match-to (match-end 0))
(setq bound
(save-excursion
(vertical-motion
(if (< direction 0)
(- (window-height))
(window-height)))
(setq bound (point))))
;; set pre-command-hook to remove match overlays eventually
(add-hook 'pre-command-hook 'regexp-lock-match-pre-command)
(while matches
(cond
((eq (car matches) nil)
(setq index (1+ index))
(setq matches (cddr matches)))
((integer-or-marker-p (car matches))
(setq overlay
(make-overlay (car matches) (cadr matches)))
(overlay-put
overlay 'before-string
(propertize (concat regexp-lock-match-before-group
(number-to-string index))
'face 'regexp-lock-match-group))
(overlay-put overlay 'priority index)
(overlay-put overlay 'window regexp-lock-match-window)
(setq regexp-lock-match-overlays
(cons overlay regexp-lock-match-overlays))
(overlay-put
overlay 'after-string
(propertize (concat (number-to-string index)
regexp-lock-match-after-group)
'face 'regexp-lock-match-group))
(overlay-put overlay 'priority index)
(overlay-put overlay 'window regexp-lock-match-window)
(setq regexp-lock-match-overlays
(cons overlay regexp-lock-match-overlays))
(setq index (1+ index))
(setq matches (cddr matches)))
(t (setq matches nil))))))))
(let ((to (or (and first regexp-lock-match-from) at)))
(save-excursion
(goto-char to)
(vertical-motion (- (window-height)))
(while (re-search-forward regexp-lock-match-regexp to t)
(cond
((= (match-beginning 0) (match-end 0))
(message "Empty match ...")
(sit-for 1)
(throw 'empty nil))
(t
(let ((overlay (make-overlay
(match-beginning 0) (match-end 0))))
(setq regexp-lock-match-overlays
(cons overlay regexp-lock-match-overlays))
(overlay-put overlay 'face 'regexp-lock-match-other)
(overlay-put
overlay 'window regexp-lock-match-window)))))
(goto-char (or (and first regexp-lock-match-to) to))
(setq to (save-excursion
(vertical-motion (window-height))
(point)))
(while (re-search-forward regexp-lock-match-regexp to t)
(cond
((= (match-beginning 0) (match-end 0))
(message "Empty match ...")
(sit-for 1)
(throw 'empty nil))
(t
(let ((overlay (make-overlay
(match-beginning 0) (match-end 0))))
(setq regexp-lock-match-overlays
(cons overlay regexp-lock-match-overlays))
(overlay-put overlay 'face 'regexp-lock-match-other)
(overlay-put
overlay 'window regexp-lock-match-window))))))))
(if first
(progn
(goto-char first)
(unless (pos-visible-in-window-p)
(if (< direction 0)
(recenter -3)
(recenter 3))))
(goto-char at)
(set-marker regexp-lock-match-from nil)
(set-marker regexp-lock-match-to nil)
(message "No (more) matches ...")
(sit-for 1))))))))
(defun regexp-lock-match-next ()
"Move to next matching expression."
(interactive)
(if (memq last-command '(regexp-lock-match-next regexp-lock-match-prev))
(regexp-lock-match 1)
(regexp-lock-match 0)))
(defun regexp-lock-match-prev ()
"Move to previous matching expression."
(interactive)
(regexp-lock-match -1))
;; _____________________________________________________________________________
;;
;;; Increment / Decrement group numbers
;; _____________________________________________________________________________
;;
(defun regexp-lock-increment (above increment start end)
"In-/Decrement group numbers within region.
Within region add INCREMENT to all arguments of `match-beginning',
`match-end', and `match-string' greater or equal ABOVE."
(interactive "nIn-/Decrement group numbers >=: \nnBy: \nr")
(save-excursion
(goto-char start)
(let ((count 0))
(while (re-search-forward
;; Added `replace-match' on 2009-08-04.
"\\((match-\\(?:beginning\\|end\\|string\\(?:-no-properties\\)?\\)[ \t\n\f]+\\([0-9]+\\))\\)\
\\|\\((replace-match\\)"
end t)
(cond
((match-beginning 1)
(let ((number (string-to-number (match-string 2))))
(when (>= number above)
(replace-match
(number-to-string (+ number increment)) nil nil nil 2)
(setq count (1+ count)))))
((match-beginning 3)
;; `replace-match' is hairy because the SUBEXP arg is optional.
(condition-case nil
(progn
(forward-sexp 4)
(forward-comment (buffer-size))
(when (looking-at "[0-9]+")
(let ((number (string-to-number (match-string 0))))
(when (>= number above)
(replace-match
(number-to-string (+ number increment)))
(setq count (1+ count))))))
(error nil)))))
(if (zerop count)
(message "No substitutions performed")
(message "%s substitution(s) performed" count)))))
(provide 'regexp-lock)
;;; regexp-lock.el ends here
^ permalink raw reply [flat|nested] 23+ messages in thread