]> code.delx.au - gnu-emacs-elpa/blobdiff - packages/el-search/el-search.el
Merge commit 'ef509502cdd228c8ce0a562bbf411e5f98beaaf1'
[gnu-emacs-elpa] / packages / el-search / el-search.el
index 496285bb6b9d57f55ff92dd1660721b438c7dd3e..a1bdd23e2b0b2473f6a6a654cdd537648cccf000 100644 (file)
@@ -7,7 +7,7 @@
 ;; Created: 29 Jul 2015
 ;; Keywords: lisp
 ;; Compatibility: GNU Emacs 25
-;; Version: 0.1.2
+;; Version: 0.1.3
 ;; Package-Requires: ((emacs "25"))
 
 
 ;;
 ;; - detect infloops when replacing automatically (e.g. for 1 -> '(1))
 ;;
-;; - highlight matches around point in a timer
-;;
 ;; - implement backward searching
 ;;
 ;; - improve docstrings
   :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"))
-                          (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.")
+
+(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)
@@ -267,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)
@@ -363,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))
@@ -372,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))
@@ -562,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."
@@ -571,6 +609,34 @@ matches the list (1 2 3 4 5 6 7 8 9) and binds `x' to (4 5 6)."
   `(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))
@@ -579,7 +645,7 @@ matches the list (1 2 3 4 5 6 7 8 9) and binds `x' to (4 5 6)."
 (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)))))
 
@@ -631,11 +697,68 @@ matches any of these expressions:
                                  "argument not a string or vector")
   `(pred (el-search--match-key-sequence ,key-sequence)))
 
+(defun el-search--s (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--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)
@@ -644,12 +767,55 @@ matches any of these expressions:
     (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
@@ -694,21 +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))))
+  (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
   "\
@@ -733,7 +903,10 @@ Hit any key to proceed."
     (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))
@@ -819,8 +992,8 @@ 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 ()
-  (let ((other-end isearch-other-end)
+(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)))
@@ -840,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)))