;; Created: 29 Jul 2015
;; Keywords: lisp
;; Compatibility: GNU Emacs 25
-;; Version: 0.1.2
+;; Version: 0.1.3
;; Package-Requires: ((emacs "25"))
;; with point at the beginning of the currently tested expression.
;;
;;
-;; Example 3:
-;;
-;; I can be useful to use (guard EXP) patterns for side effects (note:
-;; this only works when applied to the top level expression).
-;;
-;; The following pattern will search for symbols defined in any
-;; library whose name starts with "cl". As a side effect, it prints
-;; the current line number, whether we have a macro or a function, and
-;; the defining file in the echo area for each match:
-;;
-;; (and (pred symbolp)
-;; (let file (symbol-file exp))
-;; (guard file)
-;; (let lib-name (file-name-sans-extension
-;; (file-name-nondirectory file)))
-;; (guard (string-match-p "^cl" lib-name))
-;; (or (and (pred macrop) (let type "macro "))
-;; (and (pred functionp) (let type "function "))
-;; (let type ""))
-;; (guard (message "Line %d: %s`%S' (from \"%s\")"
-;; (line-number-at-pos)
-;; type
-;; exp
-;; lib-name)))
-;;
-;; `message' never returns nil, so the last `guard' always "matches".
-;;
-;;
;; Convenience
;; ===========
;;
;; so that you can always refer to the whole currently tested
;; expression via the variable `exp'.
;;
-;; Example 4:
+;;
+;; Example 3:
;;
;; If you want to search a buffer for symbols that are defined in
;; "cl-lib", you can use this pattern
;;
;; - detect infloops when replacing automatically (e.g. for 1 -> '(1))
;;
-;; - highlight matches around point in a timer
-;;
;; - implement backward searching
;;
;; - improve docstrings
:type 'symbol)
(defface el-search-match '((((background dark)) (:background "#0000A0"))
- (t (:background "DarkSlateGray1")))
+ (t (:background "DarkSlateGray3")))
"Face for highlighting the current match.")
+(defface el-search-other-match '((((background dark)) (:background "#202060"))
+ (t (:background "DarkSlateGray1")))
+ "Face for highlighting the other matches.")
+
;;;; Helpers
(mapc
(pcase-lambda (`(,symbol . ,fun))
(when-let ((doc (documentation fun)))
- (insert "\n\n-- ")
+ (insert "\n\n\n-- ")
(setq doc (help-fns--signature symbol doc fun fun nil))
(insert "\n" (or doc "Not documented."))))
(reverse el-search--pcase-macros))
(goto-char (match-end 0)))
(t (forward-char))))
-(defun el-search--search-pattern (pattern &optional noerror)
- "Search elisp buffer with `pcase' PATTERN.
-Set point to the beginning of the occurrence found and return
-point. Optional second argument, if non-nil, means if fail just
-return nil (no error)."
-
- (let ((matcher (el-search--matcher pattern)) (match-beg nil) (opoint (point)) current-expr)
+(defun el-search--search-pattern-1 (matcher &optional noerror)
+ (let ((match-beg nil) (opoint (point)) current-expr)
;; when inside a string or comment, move past it
(let ((syntax-here (syntax-ppss)))
(if noerror nil (signal 'end-of-buffer nil)))
match-beg))
+(defun el-search--search-pattern (pattern &optional noerror)
+ "Search elisp buffer with `pcase' PATTERN.
+Set point to the beginning of the occurrence found and return
+point. Optional second argument, if non-nil, means if fail just
+return nil (no error)."
+ (el-search--search-pattern-1 (el-search--matcher pattern) noerror))
+
(defun el-search--do-subsexps (pos do-fun &optional ret-fun bound)
;; In current buffer, for any expression start between POS and BOUND
;; or (point-max), in order, call two argument function DO-FUN with
;;;; Additional pattern type definitions
+(defun el-search--split (matcher1 matcher2 list)
+ "Helper for the append pattern type.
+
+When a splitting of LIST into two lists L1, L2 exist so that Li
+is matched by MATCHERi, return (L1 L2) for such Li, else return
+nil."
+ (let ((try-match (lambda (list1 list2)
+ (when (and (el-search--match-p matcher1 list1)
+ (el-search--match-p matcher2 list2))
+ (list list1 list2))))
+ (list1 list) (list2 '()) (match nil))
+ ;; don't use recursion, this could hit `max-lisp-eval-depth'
+ (while (and (not (setq match (funcall try-match list1 list2)))
+ (consp list1))
+ (let ((last-list1 (last list1)))
+ (if-let ((cdr-last-list1 (cdr last-list1)))
+ ;; list1 is a dotted list. Then list2 must be empty.
+ (progn (setcdr last-list1 nil)
+ (setq list2 cdr-last-list1))
+ (setq list1 (butlast list1 1)
+ list2 (cons (car last-list1) list2)))))
+ match))
+
+(el-search-defpattern append (&rest patterns)
+ "Matches any list factorable into lists matched by PATTERNS in order.
+
+PATTERNS is a list of patterns P1..Pn. Match any list L for that
+lists L1..Ln exist that are matched by P1..Pn in order and L is
+equal to the concatenation of L1..Ln. Ln is allowed to be no
+list.
+
+When different ways of matching are possible, it is unspecified
+which one is chosen.
+
+Example: the pattern
+
+ (append '(1 2 3) x (app car-safe 7))
+
+matches the list (1 2 3 4 5 6 7 8 9) and binds `x' to (4 5 6)."
+ (if (null patterns)
+ '(pred null)
+ (pcase-let ((`(,pattern . ,more-patterns) patterns))
+ (cond
+ ((null more-patterns) pattern)
+ ((null (cdr more-patterns))
+ `(and (pred listp)
+ (app ,(apply-partially #'el-search--split
+ (el-search--matcher pattern)
+ (el-search--matcher (car more-patterns)))
+ (,'\` ((,'\, ,pattern)
+ (,'\, ,(car more-patterns)))))))
+ (t `(append ,pattern (append ,@more-patterns)))))))
+
(el-search-defpattern string (&rest regexps)
"Matches any string that is matched by all REGEXPS."
(el-search--check-pattern-args 'string regexps #'stringp)
`(and (pred symbolp)
(app symbol-name (string ,@regexps))))
+(defun el-search--contains-p (matcher exp)
+ "Return non-nil when tree EXP contains a match for MATCHER.
+Recurse on all types of sequences. In the positive case the
+return value is (t elt), where ELT is a matching element found in
+EXP."
+ (if (el-search--match-p matcher exp)
+ (list t exp)
+ (and (sequencep exp)
+ (let ((try-match (apply-partially #'el-search--contains-p matcher)))
+ (if (consp exp)
+ (or (funcall try-match (car exp))
+ (funcall try-match (cdr exp)))
+ (cl-some try-match exp))))))
+
+(el-search-defpattern contains (&rest patterns)
+ "Matches trees that contain a match for all PATTERNs.
+Searches any tree of sequences recursively for matches. Objects
+of any kind matched by all PATTERNs are also matched.
+
+ Example: (contains (string \"H\") 17) matches ((\"Hallo\") x (5 [1 17]))"
+ (cond
+ ((null patterns) '_)
+ ((null (cdr patterns))
+ (let ((pattern (car patterns)))
+ `(app ,(apply-partially #'el-search--contains-p (el-search--matcher pattern))
+ (,'\` (t (,'\, ,pattern))))))
+ (t `(and ,@(mapcar (lambda (pattern) `(contains ,pattern)) patterns)))))
+
+(el-search-defpattern not (pattern)
+ "Matches any object that is not matched by PATTERN."
+ `(app ,(apply-partially #'el-search--match-p (el-search--matcher pattern))
+ (pred not)))
+
(defun el-search--match-symbol-file (regexp symbol)
(when-let ((symbol-file (and (symbolp symbol)
(symbol-file symbol))))
"argument not a string or vector")
`(pred (el-search--match-key-sequence ,key-sequence)))
+(defun el-search--s (expr)
+ (cond
+ ((symbolp expr) `(symbol ,(symbol-name expr)))
+ ((stringp expr) `(string ,expr))
+ (t expr)))
+
+(el-search-defpattern l (&rest lpats)
+ "Alternative pattern type for matching lists.
+Match any list with subsequent elements matched by all LPATS in
+order.
+
+The idea is to be able to search for pieces of code (i.e. lists)
+with very brief input by using a specialized syntax.
+
+An LPAT can take the following forms:
+
+SYMBOL Matches any symbol matched by SYMBOL's name interpreted as
+ a regexp
+STRING Matches any string matched by STRING interpreted as a
+ regexp
+_ Matches any list element
+__ Matches any number of list elements (including zero)
+^ Matches zero elements, but only at the beginning of a list
+$ Matches zero elements, but only at the end of a list
+PAT Anything else is interpreted as a normal pcase pattern, and
+ matches one list element matched by it
+
+^ is only valid as the first, $ as the last of the LPATS.
+
+Example: To match defuns that contain \"hl\" in their name and
+have at least one mandatory, but also optional arguments, you
+could use this pattern:
+
+ (l ^ 'defun hl (l _ &optional))"
+ (let ((match-start nil) (match-end nil))
+ (when (eq (car-safe lpats) '^)
+ (setq match-start t)
+ (cl-callf cdr lpats))
+ (when (eq (car-safe (last lpats)) '$)
+ (setq match-end t)
+ (cl-callf butlast lpats 1))
+ `(append ,@(if match-start '() '(_))
+ ,@(mapcar
+ (lambda (elt)
+ (pcase elt
+ ('__ '_)
+ ('_ '`(,_))
+ ('_? '(or '() `(,_))) ;FIXME: useful - document? or should we provide a (? PAT)
+ ;thing?
+ (_ `(,'\` ((,'\, ,(el-search--s elt)))))))
+ lpats)
+ ,@(if match-end '() '(_)))))
+
;;;; Highlighting
(defvar-local el-search-hl-overlay nil)
+(defvar-local el-search-hl-other-overlays '())
+
(defvar el-search-keep-hl nil)
(defun el-search-hl-sexp (&optional bounds)
(if (overlayp el-search-hl-overlay)
(apply #'move-overlay el-search-hl-overlay bounds)
(overlay-put (setq el-search-hl-overlay (apply #'make-overlay bounds))
- 'face 'el-search-match)))
+ 'face 'el-search-match))
+ (overlay-put el-search-hl-overlay 'priority 1002))
(add-hook 'post-command-hook #'el-search-hl-post-command-fun t t))
+(defun el-search--hl-other-matches-1 (pattern from to)
+ (mapc #'delete-overlay el-search-hl-other-overlays)
+ (setq el-search-hl-other-overlays '())
+ (let ((matcher (el-search--matcher pattern))
+ this-match-beg this-match-end
+ (done nil))
+ (save-excursion
+ (goto-char from)
+ (while (not done)
+ (setq this-match-beg (el-search--search-pattern-1 matcher t))
+ (if (not this-match-beg)
+ (setq done t)
+ (goto-char this-match-beg)
+ (setq this-match-end (el-search--end-of-sexp))
+ (let ((ov (make-overlay this-match-beg this-match-end)))
+ (overlay-put ov 'face 'el-search-other-match)
+ (overlay-put ov 'priority 1001)
+ (push ov el-search-hl-other-overlays)
+ (goto-char this-match-end)
+ (when (>= (point) to) (setq done t))))))))
+
+(defun el-search-hl-other-matches (pattern)
+ "Highlight all matches visible in the selected window."
+ (el-search--hl-other-matches-1 pattern
+ (save-excursion
+ (goto-char (window-start))
+ (beginning-of-defun-raw)
+ (point))
+ (window-end))
+ (add-hook 'window-scroll-functions #'el-search--after-scroll t t))
+
+(defun el-search--after-scroll (_win start)
+ (el-search--hl-other-matches-1 el-search-current-pattern
+ (save-excursion
+ (goto-char start)
+ (beginning-of-defun-raw)
+ (point))
+ (window-end nil t)))
+
(defun el-search-hl-remove ()
(when (overlayp el-search-hl-overlay)
- (delete-overlay el-search-hl-overlay)))
+ (delete-overlay el-search-hl-overlay))
+ (remove-hook 'window-scroll-functions #'el-search--after-scroll t)
+ (mapc #'delete-overlay el-search-hl-other-overlays)
+ (setq el-search-hl-other-overlays '()))
(defun el-search-hl-post-command-fun ()
(unless (or el-search-keep-hl
Additional `pcase' pattern types to be used with this command can
be defined with `el-search-defpattern'.
-The following additional pattern types are currently defined:\n"
+The following additional pattern types are currently defined:"
(interactive (list (if (and (eq this-command last-command)
el-search-success)
el-search-current-pattern
(when (and (eq this-command last-command) el-search-success)
(el-search--skip-expression nil t))
(setq el-search-success nil)
- (message "%s" (substitute-command-keys "Type \\[el-search-pattern] to repeat"))
(when (condition-case nil
(el-search--search-pattern pattern)
(end-of-buffer (message "No match")
(ding)
nil))
(setq el-search-success t)
- (el-search-hl-sexp))))
+ (el-search-hl-sexp)
+ (unless (eq this-command last-command)
+ (el-search-hl-other-matches pattern)))))
(defvar el-search-search-and-replace-help-string
"\
(unwind-protect
(while (and (not done) (el-search--search-pattern pattern t))
(setq opoint (point))
- (unless replace-all (el-search-hl-sexp))
+ (unless replace-all
+ (el-search-hl-sexp)
+ (unless (eq this-command last-command)
+ (el-search-hl-other-matches pattern)))
(let* ((read-mapping (el-search--create-read-map))
(region (list (point) (el-search--end-of-sexp)))
(substring (apply #'buffer-substring-no-properties region))
(el-search-search-and-replace-pattern from to mapping))
(defun el-search--take-over-from-isearch ()
- (let ((other-end isearch-other-end)
- (input isearch-string))
- (isearch-exit)
- (when (and other-end (< other-end (point)))
- (goto-char other-end))
- input))
+ (prog1 isearch-string (isearch-exit)))
;;;###autoload
(defun el-search-search-from-isearch ()