X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/40208f0670dda55ecc0fde3c851ea65cc0a45086..a6b750299b8e9c2f9342aa192004d16ea7333881:/packages/el-search/el-search.el diff --git a/packages/el-search/el-search.el b/packages/el-search/el-search.el index aac4adcab..f6c8c48e0 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.1.2 +;; Version: 0.1.3 ;; Package-Requires: ((emacs "25")) @@ -202,8 +202,6 @@ ;; ;; - detect infloops when replacing automatically (e.g. for 1 -> '(1)) ;; -;; - highlight matches around point in a timer -;; ;; - implement backward searching ;; ;; - improve docstrings @@ -244,9 +242,13 @@ prompt to refer to the value of the currently tested expression." :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 @@ -346,7 +348,7 @@ Point must not be inside a string or comment." (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)) @@ -571,6 +573,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)) @@ -631,11 +661,66 @@ 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) `(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) @@ -644,12 +729,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 @@ -679,7 +807,7 @@ 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" +The following additional pattern types are currently defined:" (interactive (list (if (and (eq this-command last-command) el-search-success) el-search-current-pattern @@ -708,7 +836,9 @@ The following additional pattern types are currently defined:\n" (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 "\ @@ -733,7 +863,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)) @@ -820,12 +953,7 @@ Hit any key to proceed." (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 ()