X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/1254161ead31da9dab50af0ae682c12a1244b338..a624a3316ee2393e39c0aaa28845cdf3eed24cb4:/packages/el-search/el-search.el diff --git a/packages/el-search/el-search.el b/packages/el-search/el-search.el index 6e9fa5e08..05cbc74af 100644 --- a/packages/el-search/el-search.el +++ b/packages/el-search/el-search.el @@ -7,7 +7,7 @@ ;; Created: 29 Jul 2015 ;; Keywords: lisp ;; Compatibility: GNU Emacs 25 -;; Version: 0.0.3 +;; Version: 0.1 ;; Package-Requires: ((emacs "25")) @@ -33,14 +33,15 @@ ;; ============ ;; ;; -;; The main user entry point is the command `el-search-pattern'. It +;; The main user entry point is `el-search-pattern'. This command ;; prompts for a `pcase' pattern and searches the current buffer for -;; expressions that are matched by it when read. Point is put at the -;; beginning of the expression found (unlike isearch). +;; matching expressions by iteratively `read'ing buffer contents. For +;; any match, point is put at the beginning of the expression found +;; (unlike isearch which puts point at the end of matches). ;; ;; It doesn't matter how the code is actually formatted. Comments are -;; ignored by the search, and strings are treated as objects, their -;; contents are not being searched. +;; ignored, and strings are treated as atomic objects, their contents +;; are not being searched. ;; ;; Example 1: if you enter ;; @@ -65,22 +66,72 @@ ;; ,(and s (guard (< 70 (length (car (split-string s "\n"))))))) ;; ;; +;; When a search pattern is processed, the searched buffer is current +;; with point at the beginning of the currently tested expression. +;; +;; +;; Example 3: +;; +;; I can be useful to use (guard EXP) patterns for side effects. +;; +;; 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 ;; =========== ;; -;; For expression input, the minibuffer prompts here uses -;; `emacs-lisp-mode'. +;; For pattern input, the minibuffer is put into `emacs-lisp-mode'. +;; +;; Any input PATTERN is silently transformed into (and exp PATTERN) +;; so that you can always refer to the whole currently tested +;; expression via the variable `exp'. ;; -;; When reading a search pattern in the minibuffer, the input is -;; automatically wrapped into `(and expr ,(read input)). So, if you -;; want to search a buffer for symbols that are defined in "cl-lib", -;; you can use this pattern +;; Example 4: ;; -;; (guard (and (symbolp expr) -;; (when-let ((file (symbol-file expr))) +;; If you want to search a buffer for symbols that are defined in +;; "cl-lib", you can use this pattern +;; +;; (guard (and (symbolp exp) +;; (when-let ((file (symbol-file exp))) ;; (string-match-p "cl-lib\\.elc?$" file)))) ;; -;; without binding the variable `expr'. +;; +;; ,---------------------------------------------------------------------- +;; | Q: "But I hate `pcase'! Can't we just do without?" | +;; | | +;; | A: Respect that you kept up until here! Just use (guard CODE), where| +;; | CODE is any normal Elisp expression that returns non-nil when and | +;; | only when you have a match. Use the variable `exp' to refer to | +;; | the currently tested expression. Just like in the last example! | +;; `---------------------------------------------------------------------- +;; +;; +;; It's cumbersome to write out the same complicated pattern +;; constructs in the minibuffer again and again. You can define your +;; own pcase pattern types for the purpose of el-search with +;; `el-search-defpattern'. It is just like `pcase-defmacro', but the +;; effect is limited to this package. See C-h f `el-search-pattern' +;; for a list of predefined additional pattern forms. ;; ;; ;; Replacing @@ -156,19 +207,23 @@ ;; ;; TODO: ;; -;; - implement backward searching and wrapped searching +;; - change replace interface to include toggle(s) ;; -;; - improve docstrings +;; - detect infloops when replacing automatically (e.g. for 1 -> '(1)) ;; -;; - add more examples +;; - highlight matches around point in a timer +;; +;; - implement backward searching +;; +;; - improve docstrings ;; ;; - handle more reader syntaxes, e.g. #n, #n# ;; ;; - Implement sessions; add multi-file support based on iterators. A -;; file list is read in (or the user can specify an iterator as a -;; variable). The state in the current buffer is just (buffer -;; . marker). Or should this be abstracted into an own lib? Could be -;; named "files-session" or so. +;; file list is read in (or the user can specify an iterator as a +;; variable). The state in the current buffer is just (buffer +;; . marker). Or should this be abstracted into an own lib? Could +;; be named "files-session" or so. @@ -182,6 +237,7 @@ (require 'cl-lib) (require 'elisp-mode) (require 'thingatpt) +(require 'help-fns) ;el-search--make-docstring ;;;; Configuration stuff @@ -191,10 +247,9 @@ :group 'lisp) (defcustom el-search-this-expression-identifier 'exp - "Name of the identifier referring to the whole expression. -The default value is `expr'. You can use this variable in the -search prompt to refer to value of the currently searched -expression." + "Name of the identifier referring to the current expression. +The default value is `exp'. You can use this name in the search +prompt to refer to the value of the currently tested expression." :type 'symbol) (defface el-search-match '((((background dark)) (:background "#0000A0")) @@ -236,12 +291,20 @@ expression." (read-from-minibuffer prompt initial-contents el-search-read-expression-map read (or hist 'read-expression-history) default))) -(defun el-search--read-pattern (prompt &optional default initial-contents read) - (el-search-read-expression - prompt initial-contents 'el-search-history - (or default (when-let ((this-sexp (sexp-at-point))) - (concat "'" (el-search--print this-sexp)))) - read)) +(defvar el-search--initial-mb-contents nil) + +(defun el-search--read-pattern (prompt &optional default read) + (let ((this-sexp (sexp-at-point))) + (minibuffer-with-setup-hook + (lambda () + (when this-sexp + (let ((more-defaults (list (concat "'" (el-search--print this-sexp))))) + (setq-local minibuffer-default-add-function + (lambda () (if (listp minibuffer-default) + (append minibuffer-default more-defaults) + (cons minibuffer-default more-defaults))))))) + (el-search-read-expression + prompt el-search--initial-mb-contents 'el-search-history default read)))) (defun el-search--end-of-sexp () ;;Point must be at sexp beginning @@ -253,7 +316,7 @@ Don't move if already at beginning of a sexp. Point must not be inside a string or comment." (let ((not-done t) res) (while not-done - (let ((stop-here nil) syntax-here + (let ((stop-here nil) (looking-at-from-back (lambda (regexp n) (save-excursion (backward-char n) @@ -263,10 +326,7 @@ Point must not be inside a string or comment." ((eobp) (signal 'end-of-buffer nil)) ((looking-at (rx (and (* space) ";"))) (forward-line)) ((looking-at (rx (+ (or space "\n")))) (goto-char (match-end 0))) - ((progn (setq syntax-here (syntax-ppss)) - (or (nth 4 syntax-here) (nth 8 syntax-here))) - (if (nth 4 syntax-here) (forward-line) (search-forward "\""))) - + ;; FIXME: can the rest be done more generically? ((and (looking-at (rx (or (syntax symbol) (syntax word)))) (not (looking-at "\\_<")) @@ -283,13 +343,116 @@ Point must not be inside a string or comment." (error (forward-char)))) res)) +(defvar el-search--pcase-macros '() + "List of additional \"el-search\" pcase macros.") + +(defun el-search--make-docstring () + ;; code mainly from `pcase--make-docstring' + (let* ((main (documentation (symbol-function 'el-search-pattern) 'raw)) + (ud (help-split-fundoc main 'pcase))) + (with-temp-buffer + (insert (or (cdr ud) main)) + (mapc + (pcase-lambda (`(,symbol . ,fun)) + (when-let ((doc (documentation fun))) + (insert "\n\n-- ") + (setq doc (help-fns--signature symbol doc nil fun nil)) + (insert "\n" (or doc "Not documented.")))) + (reverse el-search--pcase-macros)) + (let ((combined-doc (buffer-string))) + (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))))) + +(put 'el-search-pattern 'function-documentation '(el-search--make-docstring)) + +(defmacro el-search-defpattern (name args &rest body) + "Like `pcase-defmacro', but limited to el-search patterns. +The semantics is exactly that of `pcase-defmacro', but the scope +of the definitions is limited to \"el-search\"." + (declare (indent 2) (debug defun)) + `(setf (alist-get ',name el-search--pcase-macros) + (lambda ,args ,@body))) + +(el-search-defpattern string (&rest regexps) + "Matches any string that is matched by all REGEXPS." + (let ((string (make-symbol "string")) + (regexp (make-symbol "regexp"))) + `(and (pred stringp) + (pred (lambda (,string) + (cl-every + (lambda (,regexp) (string-match-p ,regexp ,string)) + (list ,@regexps))))))) + +(el-search-defpattern symbol (&rest regexps) + "Matches any symbol whose name is matched by all REGEXPS." + `(and (pred symbolp) + (app symbol-name (string ,@regexps)))) + +(defun el-search--match-symbol-file (regexp symbol) + (when-let ((symbol-file (and (symbolp symbol) + (symbol-file symbol)))) + (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." + `(pred (el-search--match-symbol-file ,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 any description of the KEY-SEQUENCE. +KEY-SEQUENCE is a key description in a format that Emacs +understands. + +This pattern matches any description of the same key sequence. + +Example: the pattern + + (keys (kbd \"C-s\")) + +matches any of these expressions: + + (kbd \"C-s\") + [(control ?s)] + \"\\C-s\" + +Any of these could be used as equivalent KEY-SEQUENCE in terms of +this pattern type." + `(pred (el-search--match-key-sequence ,key-sequence))) + +(defmacro el-search--with-additional-pcase-macros (&rest body) + `(cl-letf ,(mapcar (pcase-lambda (`(,symbol . ,fun)) + `((get ',symbol 'pcase-macroexpander) #',fun)) + el-search--pcase-macros) + ,@body)) + (defun el-search--matcher (pattern &rest body) - (let ((warning-suppress-log-types '((bytecomp)))) - (byte-compile - `(lambda (expression) - (pcase expression - (,pattern ,@(or body (list t))) - (_ nil)))))) + (eval + `(el-search--with-additional-pcase-macros + (let ((warning-suppress-log-types '((bytecomp)))) + (byte-compile + (lambda (expression) + (pcase expression + (,pattern ,@(or body (list t))) + (_ nil)))))))) (defun el-search--match-p (matcher expression) (funcall matcher expression)) @@ -297,15 +460,46 @@ Point must not be inside a string or comment." (defun el-search--wrap-pattern (pattern) `(and ,el-search-this-expression-identifier ,pattern)) +(defun el-search--skip-expression (expression &optional read) + ;; Move forward at least one character. Don't move into a string or + ;; comment. Don't move further than the beginning of the next sexp. + ;; Try to move as far as possible. Point must be at the beginning + ;; of an expression. + ;; If there are positions where `read' would succeed, but that do + ;; not represent a valid sexp start, move past them (e.g. when + ;; before "#'" move past both characters). + ;; + ;; EXPRESSION must be the (read) expression at point, but when READ + ;; is non-nil, ignore the first argument and read the expression at + ;; point instead. + (when read (setq expression (save-excursion (read (current-buffer))))) + (cond + ((or (null expression) + (equal [] expression) + (not (or (listp expression) (vectorp expression)))) + (goto-char (el-search--end-of-sexp))) + ((looking-at (rx (or ",@" "," "#'" "'"))) + (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)." - ;; For better performance we read complete top-level sexps and test - ;; for matches. We enter top-level expressions in the buffer text - ;; only when the test was successful. + (let ((matcher (el-search--matcher pattern)) (match-beg nil) (opoint (point)) current-expr) + + ;; when inside a string or comment, move past it + (let ((syntax-here (syntax-ppss))) + (when (nth 3 syntax-here) ;inside a string + (goto-char (nth 8 syntax-here)) + (forward-sexp)) + (when (nth 4 syntax-here) ;inside a comment + (forward-line 1) + (while (and (not (eobp)) (looking-at (rx (and (* space) ";")))) + (forward-line 1)))) + (if (catch 'no-match (while (not match-beg) (condition-case nil @@ -316,21 +510,25 @@ return nil (no error)." (if (el-search--match-p matcher current-expr) (setq match-beg (point) opoint (point)) - (forward-char)))) + (el-search--skip-expression current-expr)))) (if noerror nil (signal 'end-of-buffer nil))) match-beg)) (defun el-search--do-subsexps (pos do-fun &optional ret-fun bound) - ;; bound -> nil means till end of buffer + ;; In current buffer, for any expression start between POS and BOUND + ;; or (point-max), in order, call two argument function DO-FUN with + ;; the current sexp string and the ending position of the current + ;; sexp. When done, with RET-FUN given, call it with no args and + ;; return the result; else, return nil. (save-excursion (goto-char pos) (condition-case nil (while (< (point) (or bound (point-max))) (let* ((this-sexp-end (save-excursion (thing-at-point--end-of-sexp) (point))) - (this-sexp-bounds (buffer-substring-no-properties (point) this-sexp-end))) - (funcall do-fun this-sexp-bounds this-sexp-end)) - (forward-char) - (el-search--ensure-sexp-start)) + (this-sexp-string (buffer-substring-no-properties (point) this-sexp-end))) + (funcall do-fun this-sexp-string this-sexp-end) + (el-search--skip-expression (read this-sexp-string)) + (el-search--ensure-sexp-start))) (end-of-buffer)) (when ret-fun (funcall ret-fun)))) @@ -356,7 +554,7 @@ return nil (no error)." (unless (looking-at "[[:space:]\)]*$") (insert "\n") (backward-char))) - (insert old))) + (save-excursion (insert old)))) (lambda () (buffer-substring (point-min) (point-max)))))) @@ -366,27 +564,25 @@ return nil (no error)." (defvar el-search-keep-hl nil) -(defun el-search-hl-sexp-at-point () - (let ((bounds (list (point) (el-search--end-of-sexp)))) +(defun el-search-hl-sexp (&optional bounds) + (let ((bounds (or bounds + (list (point) (el-search--end-of-sexp))))) (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))) - (add-hook 'post-command-hook (el-search-hl-post-command-fun (current-buffer)) t)) + (add-hook 'post-command-hook #'el-search-hl-post-command-fun t t)) (defun el-search-hl-remove () (when (overlayp el-search-hl-overlay) (delete-overlay el-search-hl-overlay))) -(defun el-search-hl-post-command-fun (buf) - (lambda () - (when (buffer-live-p buf) - (unless (or el-search-keep-hl - (eq this-command 'el-search-query-replace) - (eq this-command 'el-search-pattern)) - (with-current-buffer buf - (el-search-hl-remove) - (remove-hook 'post-command-hook #'el-search-hl-post-command-fun t)))))) +(defun el-search-hl-post-command-fun () + (unless (or el-search-keep-hl + (eq this-command 'el-search-query-replace) + (eq this-command 'el-search-pattern)) + (el-search-hl-remove) + (remove-hook 'post-command-hook 'el-search-hl-post-command-fun t))) ;;;; Core functions @@ -399,14 +595,24 @@ return nil (no error)." ;;;###autoload (defun el-search-pattern (pattern) - "Do incremental elisp search forward." + "Start new or resume last elisp search. + +Search current buffer for expressions that are matched by `pcase' +PATTERN. Use `read' to transform buffer contents into +expressions. + + +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" (interactive (list (if (and (eq this-command last-command) el-search-success) el-search-current-pattern (let ((pattern (el-search--read-pattern "Find pcase pattern: " (car el-search-history) - nil t))) + t))) ;; A very common mistake: input "foo" instead of "'foo" (when (and (symbolp pattern) (not (eq pattern '_)) @@ -414,11 +620,13 @@ return nil (no error)." (not (eq (symbol-value pattern) pattern)))) (error "Please don't forget the quote when searching for a symbol")) (el-search--wrap-pattern pattern))))) + (setq this-command 'el-search-pattern) ;in case we come from isearch (setq el-search-current-pattern pattern) - (setq el-search-success nil) (let ((opoint (point))) - (when (eq this-command last-command) - (forward-char)) + (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") @@ -427,25 +635,31 @@ return nil (no error)." (ding) nil)) (setq el-search-success t) - (el-search-hl-sexp-at-point) - (message "%s" (substitute-command-keys "Type \\[el-search-pattern] to repeat"))))) + (el-search-hl-sexp)))) -(defun el-search-search-and-replace-pattern (pattern replacement &optional mapping) +(defun el-search-search-and-replace-pattern (pattern replacement &optional mapping splice) (let ((replace-all nil) (nbr-replaced 0) (nbr-skipped 0) (done nil) (el-search-keep-hl t) (opoint (point)) (get-replacement (el-search--matcher pattern replacement))) (unwind-protect (while (and (not done) (el-search--search-pattern pattern t)) (setq opoint (point)) - (unless replace-all (el-search-hl-sexp-at-point)) + (unless replace-all (el-search-hl-sexp)) (let* ((read-mapping (el-search--create-read-map)) (region (list (point) (el-search--end-of-sexp))) (substring (apply #'buffer-substring-no-properties region)) (expr (read substring)) (replaced-this nil) (new-expr (funcall get-replacement expr)) - (to-insert (el-search--repair-replacement-layout - (el-search--print new-expr) (append mapping read-mapping))) + (get-replacement-string + (lambda () (if (and splice (not (listp new-expr))) + (error "Expression to splice in is an atom") + (el-search--repair-replacement-layout + (if splice + (mapconcat #'el-search--print new-expr " ") + (el-search--print new-expr)) + (append mapping read-mapping))))) + (to-insert (funcall get-replacement-string)) (do-replace (lambda () (atomic-change-group (apply #'delete-region region) @@ -453,8 +667,8 @@ return nil (no error)." (opoint (point))) (insert to-insert) (indent-region opoint (point)) - (goto-char opoint) - (el-search-hl-sexp-at-point))) + (el-search-hl-sexp (list opoint (point))) + (goto-char opoint))) (cl-incf nbr-replaced) (setq replaced-this t)))) (if replace-all @@ -462,12 +676,14 @@ return nil (no error)." (while (not (pcase (if replaced-this (read-char-choice "[SPC ! q]" '(?\ ?! ?q ?n)) (read-char-choice - (concat "Replace this occurence" + (concat "Replace this occurrence" (if (or (string-match-p "\n" to-insert) (< 40 (length to-insert))) "" (format " with `%s'" to-insert)) - "? [y SPC r ! q]" ) - '(?y ?n ?r ?\ ?! ?q))) + "? " + (if splice "{splice} " "") + "[y SPC r ! q]" ) + '(?y ?n ?r ?\ ?! ?q ?s))) (?r (funcall do-replace) nil) (?y (funcall do-replace) @@ -479,9 +695,12 @@ return nil (no error)." (funcall do-replace)) (setq replace-all t) t) + (?s (cl-callf not splice) + (setq to-insert (funcall get-replacement-string)) + nil) (?q (setq done t) t))))) - (unless (or done (eobp)) (forward-char 1))))) + (unless (or done (eobp)) (el-search--skip-expression nil t))))) (el-search-hl-remove) (goto-char opoint) (message "Replaced %d matches%s" @@ -489,10 +708,11 @@ return nil (no error)." (if (zerop nbr-skipped) "" (format " (%d skipped)" nbr-skipped))))) -(defun el-search-query-replace-read-args (&optional initial-contents) +(defun el-search-query-replace-read-args () (barf-if-buffer-read-only) - (let* ((from (el-search--read-pattern "Replace from: " nil initial-contents)) - (to (el-search--read-pattern "Replace with result of evaluation of: " from))) + (let* ((from (el-search--read-pattern "Replace from: ")) + (to (let ((el-search--initial-mb-contents nil)) + (el-search--read-pattern "Replace with result of evaluation of: " from)))) (list (el-search--wrap-pattern (read from)) (read to) (with-temp-buffer (insert to) @@ -502,6 +722,7 @@ return nil (no error)." (defun el-search-query-replace (from to &optional mapping) "Replace some occurrences of FROM pattern with evaluated TO." (interactive (el-search-query-replace-read-args)) + (setq this-command 'el-search-query-replace) ;in case we come from isearch (setq el-search-current-pattern from) (barf-if-buffer-read-only) (el-search-search-and-replace-pattern from to mapping)) @@ -520,17 +741,15 @@ return nil (no error)." ;; with Isearch, using `isearch-search-fun-function'. ;; Alas, this is not trivial if we want to transfer our optimizations. (interactive) - (el-search-pattern - (el-search--read-pattern - "Find pcase pattern: " nil (concat "'" (el-search--take-over-from-isearch)) t)) - (setq this-command 'el-search-pattern)) + (let ((el-search--initial-mb-contents (concat "'" (el-search--take-over-from-isearch)))) + ;; use `call-interactively' so we get recorded in `extended-command-history' + (call-interactively #'el-search-pattern))) ;;;###autoload (defun el-search-replace-from-isearch () (interactive) - (let ((this-command 'el-search-query-replace)) - (apply #'el-search-query-replace - (el-search-query-replace-read-args (concat "'" (el-search--take-over-from-isearch)))))) + (let ((el-search--initial-mb-contents (concat "'" (el-search--take-over-from-isearch)))) + (call-interactively #'el-search-query-replace)))