From: Jim Porter Date: Mon, 20 May 2024 19:37:22 +0000 (-0700) Subject: Improve implementation of 'forward-thing' using custom providers X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=e7d67179dc979d09aadf514969817ae719f9ea26;p=emacs.git Improve implementation of 'forward-thing' using custom providers Now, call all the custom providers for each step, using the provider that moves point the smallest non-zero amount. This allows multiple providers for a given "thing" to work nicely together. * lisp/thingatpt.el (forward-thing-provider-alist): Update docstring. (forward-thing): New implementation to call each provider N times. (forward-thing-for-text-property): Take BACKWARD instead of N. Update callers. * test/lisp/thingatpt-tests.el (thing-at-point-providers) (forward-thing-providers): Add more checks. (consecutive-things-at-point): New test. (cherry picked from commit f6c60f16a231802104f53f3953b7fdc363944316) --- diff --git a/lisp/net/eww.el b/lisp/net/eww.el index ff502914eb5..be43ac2f9db 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -1382,9 +1382,9 @@ within text input fields." "`thing-at-point' provider function." (thing-at-point-for-text-property 'shr-url)) -(defun eww--forward-url (n) +(defun eww--forward-url (backward) "`forward-thing' provider function." - (forward-thing-for-text-property 'shr-url n)) + (forward-thing-for-text-property 'shr-url backward)) (defun eww--bounds-of-url-at-point () "`bounds-of-thing-at-point' provider function." diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index be162cf9e11..9b8e5c0b106 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -660,9 +660,9 @@ have been run, the auto-setup is inhibited.") "`thing-at-point' provider function." (thing-at-point-for-text-property 'bug-reference-url)) -(defun bug-reference--forward-url (n) +(defun bug-reference--forward-url (backward) "`forward-thing' provider function." - (forward-thing-for-text-property 'bug-reference-url n)) + (forward-thing-for-text-property 'bug-reference-url backward)) (defun bug-reference--bounds-of-url-at-point () "`bounds-of-thing-at-point' provider function." diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 825f49cfab7..ff0ed66d62d 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -76,12 +76,13 @@ question. `whitespace', `line', `face' and `page'.") (defvar forward-thing-provider-alist nil - "Alist of providers for moving forward to the end of a \"thing\". + "Alist of providers for moving forward to the end of the next \"thing\". This variable can be set globally, or appended to buffer-locally by modes, to provide functions that will move forward to the end of a -\"thing\" at point. Each function should take a single argument N, the -number of \"things\" to move forward past. The first provider for the -\"thing\" that returns a non-nil value wins. +\"thing\" at point. Each function should take a single argument +BACKWARD, which is non-nil if the function should instead move to the +beginning of the previous thing. The provider for \"thing\" that moves +point by the smallest non-zero distance wins. You can use this variable in much the same way as `thing-at-point-provider-alist' (which see).") @@ -106,15 +107,35 @@ Possibilities include `symbol', `list', `sexp', `defun', `number', `filename', `url', `email', `uuid', `word', `sentence', `whitespace', `line', and `page'." (setq n (or n 1)) - (or (seq-some (lambda (elt) - (and (eq (car elt) thing) - (funcall (cdr elt) n))) - forward-thing-provider-alist) - (let ((forward-op (or (get thing 'forward-op) - (intern-soft (format "forward-%s" thing))))) - (if (functionp forward-op) - (funcall forward-op n) - (error "Can't determine how to move over a %s" thing))))) + (if (assq thing forward-thing-provider-alist) + (let* ((backward (< n 0)) + (reducer (if backward #'max #'min)) + (limit (if backward (point-min) (point-max)))) + (catch 'done + (dotimes (_ (abs n)) + ;; Find the provider that moves point the smallest non-zero + ;; amount, and use that to update point. + (let ((new-point (seq-reduce + (lambda (value elt) + (if (eq (car elt) thing) + (save-excursion + (funcall (cdr elt) backward) + (if value + (funcall reducer value (point)) + (point))) + value)) + forward-thing-provider-alist nil))) + (if (and new-point (/= new-point (point))) + (goto-char new-point) + ;; If we didn't move point, move to our limit (min or max + ;; point), and terminate. + (goto-char limit) + (throw 'done t)))))) + (let ((forward-op (or (get thing 'forward-op) + (intern-soft (format "forward-%s" thing))))) + (if (functionp forward-op) + (funcall forward-op n) + (error "Can't determine how to move over a %s" thing))))) ;; General routines @@ -819,21 +840,16 @@ Each \"thing\" is a region of text with the specified text PROPERTY set." (autoload 'prop-match-beginning "text-property-search") (autoload 'prop-match-end "text-property-search") -(defun forward-thing-for-text-property (property n) - "Move forward to the end of the Nth next \"thing\". -Each \"thing\" is a region of text with the specified text PROPERTY set." - (let ((search-func (if (> n 0) #'text-property-search-forward - #'text-property-search-backward)) - (pos-func (if (> n 0) #'prop-match-end #'prop-match-beginning)) - (limit (if (> n 0) (point-max) (point-min)))) - (catch 'done - (dotimes (_ (abs n)) - (if-let ((match (funcall search-func property))) - (goto-char (funcall pos-func match)) - (goto-char limit) - (throw 'done t)))) - ;; Return non-nil. - t)) +(defun forward-thing-for-text-property (property &optional backward) + "Move forward to the end of the next \"thing\". +If BACKWARD is non-nil, move backward to the beginning of the previous +\"thing\" instead. Each \"thing\" is a region of text with the +specified text PROPERTY set." + (let ((search-func (if backward #'text-property-search-backward + #'text-property-search-forward)) + (pos-func (if backward #'prop-match-beginning #'prop-match-end))) + (when-let ((match (funcall search-func property))) + (goto-char (funcall pos-func match))))) (defun bounds-of-thing-at-point-for-text-property (property) "Determine the start and end buffer locations for the \"thing\" at point. diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index 88a4bc8a27d..c3b04f29ce5 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -270,6 +270,8 @@ position to retrieve THING.") ;; Get the URL using the first provider. (should (equal (thing-at-point 'url) "foo.com")) (should (equal (thing-at-point 'word) "hello")) + (goto-char 6) ; Go to the end of "hello". + (should (equal (thing-at-point 'url) "foo.com")) (goto-char (point-max)) ;; Get the URL using the second provider. (should (equal (thing-at-point 'url) "bar.com")))) @@ -283,13 +285,15 @@ position to retrieve THING.") (insert (propertize "hello" 'foo-url "foo.com") "there\n" (propertize "goodbye" 'bar-url "bar.com")) (goto-char (point-min)) - (save-excursion - (forward-thing 'url) ; Move past the first URL. - (should (= (point) 6)) - (forward-thing 'url) ; Move past the second URL. - (should (= (point) 19))) - (goto-char (point-min)) ; Go back to the beginning... - (forward-thing 'word) ; ... and move past the first word. + (forward-thing 'url) ; Move past the first URL. + (should (= (point) 6)) + (forward-thing 'url) ; Move past the second URL. + (should (= (point) 19)) + (forward-thing 'url -1) ; Move backwards past the second URL. + (should (= (point) 12)) + (forward-thing 'url -1) ; Move backwards past the first URL. + (should (= (point) 1)) + (forward-thing 'word) ; Move past the first word. (should (= (point) 11)))) (ert-deftest bounds-of-thing-at-point-providers () @@ -317,4 +321,30 @@ position to retrieve THING.") (should (eq (save-excursion (beginning-of-thing 'url)) 12)) (should (eq (save-excursion (end-of-thing 'url)) 19)))) +(ert-deftest consecutive-things-at-point () + (with-temp-buffer + (setq-local + thing-at-point-provider-alist + `((url . ,(lambda () (thing-at-point-for-text-property 'url)))) + forward-thing-provider-alist + `((url . ,(lambda (n) (forward-thing-for-text-property 'url n)))) + bounds-of-thing-at-point-provider-alist + `((url . ,(lambda () (bounds-of-thing-at-point-for-text-property 'url))))) + (insert (propertize "one" 'url "foo.com") + (propertize "two" 'url "bar.com") + (propertize "three" 'url "baz.com")) + (goto-char 4) ; Go to the end of "one". + (should (equal (thing-at-point 'url) "bar.com")) + (should (equal (bounds-of-thing-at-point 'url) '(4 . 7))) + (forward-thing 'url) + (should (= (point) 7)) + (should (equal (thing-at-point 'url) "baz.com")) + (should (equal (bounds-of-thing-at-point 'url) '(7 . 12))) + (forward-thing 'url) + (should (= (point) 12)) + (forward-thing 'url -2) + (should (= (point) 4)) + (should (equal (thing-at-point 'url) "bar.com")) + (should (equal (bounds-of-thing-at-point 'url) '(4 . 7))))) + ;;; thingatpt-tests.el ends here