+(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--format-replacement (replacement original replace-expr-input splice)
+ ;; Return a printed representation of REPLACEMENT. Try to reuse the
+ ;; layout of subexpressions shared with the original (replaced)
+ ;; expression and the replace expression.
+ (if (and splice (not (listp replacement)))
+ (error "Expression to splice in is an atom")
+ (let ((orig-buffer (generate-new-buffer "orig-expr")))
+ (with-current-buffer orig-buffer
+ (emacs-lisp-mode)
+ (insert original)
+ (when replace-expr-input (insert "\n\n" replace-expr-input)))
+ (unwind-protect
+ (with-temp-buffer
+ (emacs-lisp-mode)
+ (insert (if splice
+ (mapconcat #'el-search--pp-to-string replacement " ")
+ (el-search--pp-to-string replacement)))
+ (goto-char 1)
+ (let (start this-sexp end orig-match-start orig-match-end done)
+ (while (and (< (point) (point-max))
+ (condition-case nil
+ (progn
+ (setq start (point)
+ this-sexp (read (current-buffer))
+ end (point))
+ t)
+ (end-of-buffer nil)))
+ (setq done nil orig-match-start nil)
+ (with-current-buffer orig-buffer
+ (goto-char 1)
+ (if (el-search--search-pattern `',this-sexp t)
+ (setq orig-match-start (point)
+ orig-match-end (progn (forward-sexp) (point)))
+ (setq done t)))
+ ;; find out whether we have a sequence of equal expressions
+ (while (and (not done)
+ (condition-case nil
+ (progn (setq this-sexp (read (current-buffer))) t)
+ ((invalid-read-syntax end-of-buffer end-of-file) nil)))
+ (if (with-current-buffer orig-buffer
+ (condition-case nil
+ (if (not (equal this-sexp (read (current-buffer))))
+ nil
+ (setq orig-match-end (point))
+ t)
+ ((invalid-read-syntax end-of-buffer end-of-file) nil)))
+ (setq end (point))
+ (setq done t)))
+ (if orig-match-start
+ (let ((match (with-current-buffer orig-buffer
+ (buffer-substring-no-properties orig-match-start
+ orig-match-end))))
+ (delete-region start end)
+ (goto-char start)
+ (when (string-match-p "\n" match)
+ (unless (looking-back "^[[:space:]\(]*" (line-beginning-position))
+ (insert "\n"))
+ (unless (looking-at "[[:space:]\)]*$")
+ (insert "\n")
+ (backward-char)))
+ (insert match))
+ (goto-char start)
+ (el-search--skip-expression nil t))
+ (condition-case nil
+ (el-search--ensure-sexp-start)
+ (end-of-buffer (goto-char (point-max))))))
+ (delete-trailing-whitespace (point-min) (point-max)) ;FIXME: this should not be necessary
+ (let ((result (buffer-substring (point-min) (point-max))))
+ (if (equal replacement (read result))
+ result
+ (error "Error in `el-search--format-replacement' - please make a bug report"))))
+ (kill-buffer orig-buffer)))))
+
+(defun el-search--check-pattern-args (type args predicate &optional message)
+ "Check whether all ARGS fulfill PREDICATE.
+Raise an error if not. The string arguments TYPE and optional
+MESSAGE are used to construct the error message."
+ (mapc (lambda (arg)
+ (unless (funcall predicate arg)
+ (error (concat "Pattern `%s': "
+ (or message (format "argument doesn't fulfill %S" predicate))
+ ": %S")
+ type arg)))
+ args))
+
+(defvar el-search-current-pattern nil)
+
+(defvar el-search-success nil)
+
+
+;;;; 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)))))))
+
+(defun el-search--stringish-p (thing)
+ (or (stringp thing) (and el-search-use-sloppy-strings (symbolp thing))))
+
+(el-search-defpattern string (&rest regexps)
+ "Matches any string that is matched by all REGEXPS."
+ (el-search--check-pattern-args "string" regexps #'el-search--stringish-p
+ "Argument not a string")
+ `(and (pred stringp)
+ ,@(mapcar (lambda (thing) `(pred (el-search--smart-string-match-p
+ ,(if (symbolp thing) (symbol-name thing) thing))))
+ regexps)))
+
+(el-search-defpattern symbol (&rest regexps)
+ "Matches any symbol whose name is matched by all REGEXPS."
+ (el-search--check-pattern-args "symbol" regexps #'el-search--stringish-p
+ "Argument not a string")
+ `(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))))
+ (el-search--smart-string-match-p
+ (if (symbolp regexp) (concat "\\`" (symbol-name regexp) "\\'") regexp)
+ (file-name-sans-extension (file-name-nondirectory symbol-file)))))
+
+(el-search-defpattern source (regexp)
+ "Matches any symbol whose `symbol-file' is matched by REGEXP.
+
+This pattern matches when the object is a symbol for that
+`symbol-file' returns a (non-nil) FILE-NAME that fulfills
+ (string-match-p REGEXP (file-name-sans-extension
+ (file-name-nondirectory FILENAME)))
+
+REGEXP can also be a symbol, in which case
+
+ (concat \"^\" (symbol-name regexp) \"$\")
+
+is used as regular expression."
+ (el-search--check-pattern-args "source" (list regexp) #'el-search--stringish-p
+ "Argument not a string")
+ `(pred (el-search--match-symbol-file ,(if (symbolp regexp) (symbol-name regexp) regexp))))
+
+(defun el-search--match-key-sequence (keys expr)
+ (when-let ((expr-keys (pcase expr
+ ((or (pred stringp) (pred vectorp)) expr)
+ (`(kbd ,(and (pred stringp) string)) (ignore-errors (kbd string))))))
+ (apply #'equal
+ (mapcar (lambda (keys) (ignore-errors (key-description keys)))
+ (list keys expr-keys)))))
+
+(el-search-defpattern keys (key-sequence)
+ "Matches descriptions of the KEY-SEQUENCE.
+KEY-SEQUENCE is a string or vector representing a key sequence,
+or an expression of the form (kbd STRING).
+
+Match any description of the same key sequence in any of these
+formats.
+
+Example: the pattern
+
+ (keys (kbd \"C-s\"))
+
+matches any of these expressions:
+
+ \"\\C-s\"
+ \"\C-s\"
+ (kbd \"C-s\")
+ [(control ?s)]"
+ (when (eq (car-safe key-sequence) 'kbd)
+ (setq key-sequence (kbd (cadr key-sequence))))
+ (el-search--check-pattern-args "keys" (list key-sequence) (lambda (x) (or (stringp x) (vectorp x)))
+ "argument not a string or vector")
+ `(pred (el-search--match-key-sequence ,key-sequence)))
+
+(defun el-search--transform-nontrivial-lpat (expr)
+ (cond
+ ((symbolp expr) `(or (symbol ,(symbol-name expr))
+ (,'\` (,'quote (,'\, (symbol ,(symbol-name expr)))))
+ (,'\` (,'function (,'\, (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 S matched by SYMBOL's name interpreted
+ as a regexp. Matches also 'S and #'S for any such S.
+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--transform-nontrivial-lpat elt)))))))
+ lpats)
+ ,@(if match-end '() '(_)))))
+
+(el-search-defpattern char-prop (property)
+ "Matches the object if completely covered with PROPERTY.
+This pattern matches the object if its representation in the
+search buffer is completely covered with the character property
+PROPERTY.
+
+This pattern always tests the complete expression in the search
+buffer, it is not possible to test subexpressions calculated in
+the search pattern."
+ `(guard (and (get-char-property (point) ',property)
+ ,(macroexp-let2 nil limit '(scan-sexps (point) 1)
+ `(= (next-single-char-property-change
+ (point) ',property nil ,limit)
+ ,limit)))))
+
+(el-search-defpattern includes-prop (property)
+ "Matches the object if partly covered with PROPERTY.
+This pattern matches the object if its representation in the
+search buffer is partly covered with the character property
+PROPERTY.
+
+This pattern always tests the complete expression in the search
+buffer, it is not possible to test subexpressions calculated in
+the search pattern."
+ `(guard (or (get-char-property (point) ',property)
+ ,(macroexp-let2 nil limit '(scan-sexps (point) 1)
+ `(not (= (next-single-char-property-change
+ (point) ',property nil ,limit)
+ ,limit))))))
+
+(el-search-defpattern change ()
+ "Matches the object if it is part of a change.
+This is equivalent to (char-prop diff-hl-hunk).
+
+You need `diff-hl-mode' turned on, provided by the library
+\"diff-hl\" available in Gnu Elpa."
+ (or (bound-and-true-p diff-hl-mode)
+ (error "diff-hl-mode not enabled"))
+ '(char-prop diff-hl-hunk))
+
+(el-search-defpattern changed ()
+ "Matches the object if it contains a change.
+This is equivalent to (includes-prop diff-hl-hunk).
+
+You need `diff-hl-mode' turned on, provided by the library
+\"diff-hl\" available in Gnu Elpa."
+ (or (bound-and-true-p diff-hl-mode)
+ (error "diff-hl-mode not enabled"))
+ '(includes-prop diff-hl-hunk))