X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/9df64fc64f09c459c22894c8bfa88dce054afbe0..9d24d5d30085ba6d9a62d3f8ea2d52a358ea98c8:/packages/el-search/el-search.el diff --git a/packages/el-search/el-search.el b/packages/el-search/el-search.el index f6c8c48e0..a1bdd23e2 100644 --- a/packages/el-search/el-search.el +++ b/packages/el-search/el-search.el @@ -236,9 +236,13 @@ :group 'lisp) (defcustom el-search-this-expression-identifier 'exp - "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." + "Identifier referring to the current expression in pattern input. +When entering a PATTERN in an interactive \"el-search\" command, +the pattern actually used will be + + `(and ,el-search-this-expression-identifier ,pattern) + +The default value is `exp'." :type 'symbol) (defface el-search-match '((((background dark)) (:background "#0000A0")) @@ -249,9 +253,28 @@ prompt to refer to the value of the currently tested expression." (t (:background "DarkSlateGray1"))) "Face for highlighting the other matches.") +(defcustom el-search-smart-case-fold-search t + "Whether to use smart case folding in pattern matching. +When an \"el-search\" pattern involves regexp matching (like for +\"string\" or \"source\") and this option is non-nil, +case-fold-search will be temporarily bound to t if the according +regexp contains any upper case letter, and nil else. This is +done independently for every single matching operation. + +If nil, the value of `case-fold-search' is decisive." + :type 'boolean) + ;;;; Helpers +(defun el-search--smart-string-match-p (regexp string) + "`string-match-p' taking `el-search-smart-case-fold-search' into account." + (let ((case-fold-search (if el-search-smart-case-fold-search + (not (let ((case-fold-search nil)) + (string-match-p "[[:upper:]]" regexp))) + case-fold-search))) + (string-match-p regexp string))) + (defun el-search--print (expr) (let ((print-quoted t) (print-length nil) @@ -269,44 +292,45 @@ prompt to refer to the value of the currently tested expression." map) "Map for reading input with `el-search-read-expression'.") +(defun el-search--setup-minibuffer () + (emacs-lisp-mode) + (use-local-map el-search-read-expression-map) + (setq font-lock-mode t) + (funcall font-lock-function 1) + (backward-sexp) + (indent-sexp) + (goto-char (point-max)) + (when-let ((this-sexp (with-current-buffer (window-buffer (minibuffer-selected-window)) + (thing-at-point 'sexp)))) + (let ((more-defaults (list (concat "'" this-sexp)))) + (setq-local minibuffer-default-add-function + (lambda () (if (listp minibuffer-default) + (append minibuffer-default more-defaults) + (cons minibuffer-default more-defaults))))))) + ;; $$$$$FIXME: this should be in Emacs! There is only a helper `read--expression'. (defun el-search-read-expression (prompt &optional initial-contents hist default read) "Read expression for `my-eval-expression'." - (minibuffer-with-setup-hook - (lambda () - (emacs-lisp-mode) - (use-local-map el-search-read-expression-map) - (setq font-lock-mode t) - (funcall font-lock-function 1) - (backward-sexp) - (indent-sexp) - (goto-char (point-max))) + (minibuffer-with-setup-hook #'el-search--setup-minibuffer (read-from-minibuffer prompt initial-contents el-search-read-expression-map read (or hist 'read-expression-history) default))) (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)))) + (let ((input (el-search-read-expression + prompt el-search--initial-mb-contents 'el-search-history default read))) + (if (or read (not (string= input ""))) input (car el-search-history)))) (defun el-search--end-of-sexp () ;;Point must be at sexp beginning (or (scan-sexps (point) 1) (point-max))) (defun el-search--ensure-sexp-start () - "Move point to the beginning of the next sexp if necessary. -Don't move if already at beginning of a sexp. -Point must not be inside a string or comment." + "Move point to the next sexp beginning position. +Don't move if already at beginning of a sexp. Point must not be +inside a string or comment. `read' the expression at that point +and return it." (let ((not-done t) res) (while not-done (let ((stop-here nil) @@ -365,6 +389,17 @@ of the definitions is limited to \"el-search\"." `(setf (alist-get ',name el-search--pcase-macros) (lambda ,args ,@body))) +(defun el-search--macroexpand-1 (pattern) + "Expand \"el-search\" PATTERN. +This is like `pcase--macroexpand', but expands only patterns +defined with `el-search-defpattern' and performs only one +expansion step. + +Return PATTERN if this pattern type was not defined with +`el-search-defpattern'." + (if-let ((expander (alist-get (car-safe pattern) el-search--pcase-macros))) + (apply expander (cdr pattern)) + pattern)) (defmacro el-search--with-additional-pcase-macros (&rest body) `(cl-letf ,(mapcar (pcase-lambda (`(,symbol . ,fun)) @@ -374,14 +409,15 @@ of the definitions is limited to \"el-search\"." (defun el-search--matcher (pattern &rest body) (eval ;use `eval' to allow for user defined pattern types at run time - `(el-search--with-additional-pcase-macros - (let ((byte-compile-debug t) ;make undefined pattern types raise an error - (warning-suppress-log-types '((bytecomp))) - (pcase--dontwarn-upats (cons '_ pcase--dontwarn-upats))) - (byte-compile (lambda (expression) - (pcase expression - (,pattern ,@(or body (list t))) - (_ nil)))))))) + (let ((expression (make-symbol "expression"))) + `(el-search--with-additional-pcase-macros + (let ((byte-compile-debug t) ;make undefined pattern types raise an error + (warning-suppress-log-types '((bytecomp))) + (pcase--dontwarn-upats (cons '_ pcase--dontwarn-upats))) + (byte-compile (lambda (,expression) + (pcase ,expression + (,pattern ,@(or body (list t))) + (_ nil))))))))) (defun el-search--match-p (matcher expression) (funcall matcher expression)) @@ -564,8 +600,8 @@ matches the list (1 2 3 4 5 6 7 8 9) and binds `x' to (4 5 6)." `(and (pred stringp) (pred (lambda (,string) (cl-every - (lambda (,regexp) (string-match-p ,regexp ,string)) - (list ,@regexps))))))) + (lambda (,regexp) (el-search--smart-string-match-p ,regexp ,string)) + ',regexps)))))) (el-search-defpattern symbol (&rest regexps) "Matches any symbol whose name is matched by all REGEXPS." @@ -609,7 +645,7 @@ of any kind matched by all PATTERNs are also matched. (defun el-search--match-symbol-file (regexp symbol) (when-let ((symbol-file (and (symbolp symbol) (symbol-file symbol)))) - (string-match-p + (el-search--smart-string-match-p (if (symbolp regexp) (concat "\\`" (symbol-name regexp) "\\'") regexp) (file-name-sans-extension (file-name-nondirectory symbol-file))))) @@ -663,7 +699,9 @@ matches any of these expressions: (defun el-search--s (expr) (cond - ((symbolp expr) `(symbol ,(symbol-name expr))) + ((symbolp expr) `(or (symbol ,(symbol-name expr)) + (,'\` (,'quote (,'\, (symbol ,(symbol-name expr))))) + (,'\` (,'function (,'\, (symbol ,(symbol-name expr))))))) ((stringp expr) `(string ,expr)) (t expr))) @@ -677,8 +715,8 @@ 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 +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 @@ -822,23 +860,25 @@ The following additional pattern types are currently defined:" (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) - (let ((opoint (point))) - (when (and (eq this-command last-command) el-search-success) - (el-search--skip-expression nil t)) - (setq el-search-success nil) - (when (condition-case nil - (el-search--search-pattern pattern) - (end-of-buffer (message "No match") - (goto-char opoint) - (el-search-hl-remove) - (ding) - nil)) - (setq el-search-success t) - (el-search-hl-sexp) - (unless (eq this-command last-command) - (el-search-hl-other-matches pattern))))) + (if (not (called-interactively-p 'any)) + (el-search--search-pattern pattern) + (setq this-command 'el-search-pattern) ;in case we come from isearch + (setq el-search-current-pattern pattern) + (let ((opoint (point))) + (when (and (eq this-command last-command) el-search-success) + (el-search--skip-expression nil t)) + (setq el-search-success nil) + (when (condition-case nil + (el-search--search-pattern pattern) + (end-of-buffer (message "No match") + (goto-char opoint) + (el-search-hl-remove) + (ding) + nil)) + (setq el-search-success t) + (el-search-hl-sexp) + (unless (eq this-command last-command) + (el-search-hl-other-matches pattern)))))) (defvar el-search-search-and-replace-help-string "\ @@ -952,8 +992,13 @@ Hit any key to proceed." (barf-if-buffer-read-only) (el-search-search-and-replace-pattern from to mapping)) -(defun el-search--take-over-from-isearch () - (prog1 isearch-string (isearch-exit))) +(defun el-search--take-over-from-isearch (&optional goto-left-end) + (let ((other-end (and goto-left-end isearch-other-end)) + (input isearch-string)) + (isearch-exit) + (when (and other-end (< other-end (point))) + (goto-char other-end)) + input)) ;;;###autoload (defun el-search-search-from-isearch () @@ -968,7 +1013,7 @@ Hit any key to proceed." ;;;###autoload (defun el-search-replace-from-isearch () (interactive) - (let ((el-search--initial-mb-contents (concat "'" (el-search--take-over-from-isearch)))) + (let ((el-search--initial-mb-contents (concat "'" (el-search--take-over-from-isearch t)))) (call-interactively #'el-search-query-replace)))