On 4/30/2024 4:39 AM, Ihor Radchenko wrote:
What happens if you have multiple providers for an URL?
You add the provider to the end, so it will have the lower priority in
this scenario. I guess that you want the opposite - EWW provider to take
precedence. Same for other changes.
That's probably reasonable. I was just keeping things the way they were
historically here, but we might as well fix this now.
It would make sense to add tests for "first wins" behaviour.
Done.
I've also fixed a bug in EWW and bug-reference-mode where it would
return nil for (thing-at-point 'url) if point was at the *end* of a URL.
It's now consistent with how 'thing-at-point' works by default. (If you
have two consecutive URLs and point is between them - only possible with
the custom provider function, I think - it'll prefer the second one.)
From da26f0160c955f15e123e5b28cf8a9f514395e21 Mon Sep 17 00:00:00 2001
From: Jim Porter <jporterb...@gmail.com>
Date: Sun, 28 Apr 2024 21:19:53 -0700
Subject: [PATCH] Allow defining custom providers for more "thingatpt"
functions
This also fixes an issue in EWW and bug-reference-mode where
(thing-at-point 'url) at the end of a URL would return nil.
* lisp/thingatpt.el (forward-thing-provider-alist)
(bounds-of-thing-at-point-provider-alist): New variables...
(forward-thing, bounds-of-thing-at-point): ... use them.
(text-property-search-forward, text-property-search-backward)
(prop-match-beginning, prop-match-end): Declare.
(thing-at-point-for-text-property, forward-thing-for-text-property)
(bounds-of-thing-at-point-for-text-property): New functions.
* lisp/net/eww.el (eww--url-at-point): Use
'thing-at-point-for-text-property'.
(eww--bounds-of-url-at-point, eww--forward-url): New functions...
(eww-mode): ... use them.
* lisp/progmodes/bug-reference.el (bug-reference--url-at-point): Use
'thing-at-point-for-text-property'.
(bug-reference--bounds-of-url-at-point, bug-reference--forward-url): New
functions...
(bug-reference--init): ... use them.
* test/lisp/thingatpt-tests.el (thing-at-point-providers)
(forward-thing-providers, bounds-of-thing-at-point-providers): New
tests.
* etc/NEWS: Announce this change.
---
etc/NEWS | 25 ++++++++--
lisp/net/eww.el | 21 +++++++--
lisp/progmodes/bug-reference.el | 26 +++++++++--
lisp/thingatpt.el | 83 +++++++++++++++++++++++++++++++--
test/lisp/thingatpt-tests.el | 59 +++++++++++++++++++++++
5 files changed, 198 insertions(+), 16 deletions(-)
diff --git a/etc/NEWS b/etc/NEWS
index 7efb4110bcd..061161bb2fd 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1591,19 +1591,34 @@ of the currently existing keyboards macros using the
new mode
duplicating them, deleting them, and editing their counters, formats,
and keys.
-** Miscellaneous
+** Thingatpt
---
-*** Webjump now assumes URIs are HTTPS instead of HTTP.
-For links in 'webjump-sites' without an explicit URI scheme, it was
-previously assumed that they should be prefixed with "http://";. Such
-URIs are now prefixed with "https://"; instead.
+*** New variables for providing custom thingatpt implementations.
+The new variables 'bounds-of-thing-at-point-provider-alist' and
+'forward-thing-provider-alist' now allow defining custom implementations
+of 'bounds-of-thing-at-point' and 'forward-thing', respectively.
+
+---
+*** New helper functions for text property-based thingatpt providers.
+The new helper functions 'thing-at-point-for-text-property',
+'bounds-of-thing-at-point-for-text-property', and
+'forward-thing-for-text-property' can help to help implement custom
+thingatpt providers for "things" that are defined by a text property.
---
*** 'bug-reference-mode' now supports 'thing-at-point'.
Now, calling '(thing-at-point 'url)' when point is on a bug reference
will return the URL for that bug.
+** Miscellaneous
+
+---
+*** Webjump now assumes URIs are HTTPS instead of HTTP.
+For links in 'webjump-sites' without an explicit URI scheme, it was
+previously assumed that they should be prefixed with "http://";. Such
+URIs are now prefixed with "https://"; instead.
+
+++
*** New user option 'rcirc-log-time-format'
This allows for rcirc logs to use a custom timestamp format, than the
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index 39ea964d47a..b3997786d9e 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -1318,9 +1318,16 @@ eww-mode
;; desktop support
(setq-local desktop-save-buffer #'eww-desktop-misc-data)
(setq truncate-lines t)
+ ;; thingatpt support
(setq-local thing-at-point-provider-alist
- (append thing-at-point-provider-alist
- '((url . eww--url-at-point))))
+ (cons '(url . eww--url-at-point)
+ thing-at-point-provider-alist))
+ (setq-local forward-thing-provider-alist
+ (cons '(url . eww--forward-url)
+ forward-thing-provider-alist))
+ (setq-local bounds-of-thing-at-point-provider-alist
+ (cons '(url . eww--bounds-of-url-at-point)
+ bounds-of-thing-at-point-provider-alist))
(setq-local bookmark-make-record-function #'eww-bookmark-make-record)
(buffer-disable-undo)
(setq-local shr-url-transformer #'eww--transform-url)
@@ -1349,7 +1356,15 @@ eww--rescale-images
(defun eww--url-at-point ()
"`thing-at-point' provider function."
- (get-text-property (point) 'shr-url))
+ (thing-at-point-for-text-property 'shr-url))
+
+(defun eww--forward-url (n)
+ "`forward-thing' provider function."
+ (forward-thing-for-text-property 'shr-url n))
+
+(defun eww--bounds-of-url-at-point ()
+ "`bounds-of-thing-at-point' provider function."
+ (bounds-of-thing-at-point-for-text-property 'shr-url))
;;;###autoload
(defun eww-browse-url (url &optional new-window)
diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el
index 977a3d72cb7..be162cf9e11 100644
--- a/lisp/progmodes/bug-reference.el
+++ b/lisp/progmodes/bug-reference.el
@@ -658,19 +658,39 @@ bug-reference--run-auto-setup
(defun bug-reference--url-at-point ()
"`thing-at-point' provider function."
- (get-char-property (point) 'bug-reference-url))
+ (thing-at-point-for-text-property 'bug-reference-url))
+
+(defun bug-reference--forward-url (n)
+ "`forward-thing' provider function."
+ (forward-thing-for-text-property 'bug-reference-url n))
+
+(defun bug-reference--bounds-of-url-at-point ()
+ "`bounds-of-thing-at-point' provider function."
+ (bounds-of-thing-at-point-for-text-property 'bug-reference-url))
(defun bug-reference--init (enable)
(if enable
(progn
(jit-lock-register #'bug-reference-fontify)
(setq-local thing-at-point-provider-alist
- (append thing-at-point-provider-alist
- '((url . bug-reference--url-at-point)))))
+ (cons '(url . bug-reference--url-at-point)
+ thing-at-point-provider-alist))
+ (setq-local forward-thing-provider-alist
+ (cons '(url . bug-reference--forward-url)
+ forward-thing-provider-alist))
+ (setq-local bounds-of-thing-at-point-provider-alist
+ (cons '(url . bug-reference--bounds-of-url-at-point)
+ bounds-of-thing-at-point-provider-alist)))
(jit-lock-unregister #'bug-reference-fontify)
(setq thing-at-point-provider-alist
(delete '((url . bug-reference--url-at-point))
thing-at-point-provider-alist))
+ (setq forward-thing-provider-alist
+ (delete '((url . bug-reference--forward-url))
+ forward-thing-provider-alist))
+ (setq bounds-of-thing-at-point-provider-alist
+ (delete '((url . bug-reference--bounds-of-url-at-point))
+ bounds-of-thing-at-point-provider-alist))
(save-restriction
(widen)
(bug-reference-unfontify (point-min) (point-max)))))
diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el
index 7896ad984df..825f49cfab7 100644
--- a/lisp/thingatpt.el
+++ b/lisp/thingatpt.el
@@ -75,6 +75,27 @@ thing-at-point-provider-alist
`existing-filename', `url', `email', `uuid', `word', `sentence',
`whitespace', `line', `face' and `page'.")
+(defvar forward-thing-provider-alist nil
+ "Alist of providers for moving forward to the end of a \"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.
+
+You can use this variable in much the same way as
+`thing-at-point-provider-alist' (which see).")
+
+(defvar bounds-of-thing-at-point-provider-alist nil
+ "Alist of providers to return the bounds of a \"thing\" at point.
+This variable can be set globally, or appended to buffer-locally by
+modes, to provide functions that will return the bounds of a \"thing\"
+at point. The first provider for the \"thing\" that returns a non-nil
+value wins.
+
+You can use this variable in much the same way as
+`thing-at-point-provider-alist' (which see).")
+
;; Basic movement
;;;###autoload
@@ -84,11 +105,16 @@ forward-thing
Possibilities include `symbol', `list', `sexp', `defun', `number',
`filename', `url', `email', `uuid', `word', `sentence', `whitespace',
`line', and `page'."
- (let ((forward-op (or (get thing 'forward-op)
- (intern-soft (format "forward-%s" thing)))))
- (if (functionp forward-op)
- (funcall forward-op (or n 1))
- (error "Can't determine how to move over a %s" thing))))
+ (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)))))
;; General routines
@@ -106,6 +132,10 @@ bounds-of-thing-at-point
Return a cons cell (START . END) giving the start and end
positions of the thing found."
(cond
+ ((seq-some (lambda (elt)
+ (and (eq (car elt) thing)
+ (funcall (cdr elt))))
+ bounds-of-thing-at-point-provider-alist))
((get thing 'bounds-of-thing-at-point)
(funcall (get thing 'bounds-of-thing-at-point)))
;; If the buffer is totally empty, give up.
@@ -775,4 +805,47 @@ list-at-point
(goto-char (or (nth 8 ppss) (point)))
(form-at-point 'list 'listp))))
+;; Provider helper functions
+
+(defun thing-at-point-for-text-property (property)
+ "Return the \"thing\" at point.
+Each \"thing\" is a region of text with the specified text PROPERTY set."
+ (or (get-text-property (point) property)
+ (and (> (point) (point-min))
+ (get-text-property (1- (point)) property))))
+
+(autoload 'text-property-search-forward "text-property-search")
+(autoload 'text-property-search-backward "text-property-search")
+(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 bounds-of-thing-at-point-for-text-property (property)
+ "Determine the start and end buffer locations for the \"thing\" at point.
+The \"thing\" is a region of text with the specified text PROPERTY set."
+ (let ((pos (point)))
+ (when (or (get-text-property pos property)
+ (and (> pos (point-min))
+ (get-text-property (setq pos (1- pos)) property)))
+ (cons (or (previous-single-property-change
+ (min (1+ pos) (point-max)) property)
+ (point-min))
+ (or (next-single-property-change pos property)
+ (point-max))))))
+
;;; thingatpt.el ends here
diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el
index e50738f1122..88a4bc8a27d 100644
--- a/test/lisp/thingatpt-tests.el
+++ b/test/lisp/thingatpt-tests.el
@@ -258,4 +258,63 @@ test-numbers-hex-c
(should (equal (test--number "0xf00" 2) 3840))
(should (equal (test--number "0xf00" 3) 3840)))
+(ert-deftest thing-at-point-providers ()
+ (with-temp-buffer
+ (setq-local
+ thing-at-point-provider-alist
+ `((url . ,(lambda () (thing-at-point-for-text-property 'foo-url)))
+ (url . ,(lambda () (thing-at-point-for-text-property 'bar-url)))))
+ (insert (propertize "hello" 'foo-url "foo.com") "\n"
+ (propertize "goodbye" 'bar-url "bar.com"))
+ (goto-char (point-min))
+ ;; Get the URL using the first provider.
+ (should (equal (thing-at-point 'url) "foo.com"))
+ (should (equal (thing-at-point 'word) "hello"))
+ (goto-char (point-max))
+ ;; Get the URL using the second provider.
+ (should (equal (thing-at-point 'url) "bar.com"))))
+
+(ert-deftest forward-thing-providers ()
+ (with-temp-buffer
+ (setq-local
+ forward-thing-provider-alist
+ `((url . ,(lambda (n) (forward-thing-for-text-property 'foo-url n)))
+ (url . ,(lambda (n) (forward-thing-for-text-property 'bar-url n)))))
+ (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.
+ (should (= (point) 11))))
+
+(ert-deftest bounds-of-thing-at-point-providers ()
+ (with-temp-buffer
+ (setq-local
+ bounds-of-thing-at-point-provider-alist
+ `((url . ,(lambda ()
+ (bounds-of-thing-at-point-for-text-property 'foo-url)))
+ (url . ,(lambda ()
+ (bounds-of-thing-at-point-for-text-property 'bar-url)))))
+ (insert (propertize "hello" 'foo-url "foo.com") "there\n"
+ (propertize "goodbye" 'bar-url "bar.com"))
+ (goto-char (point-min))
+ ;; Look for a URL, using the first provider above.
+ (should (equal (bounds-of-thing-at-point 'url) '(1 . 6)))
+ (should (eq (save-excursion (beginning-of-thing 'url)) 1))
+ (should (eq (save-excursion (end-of-thing 'url)) 6))
+ ;; Look for a word, which should *not* use our provider above.
+ (should (equal (bounds-of-thing-at-point 'word) '(1 . 11)))
+ (should (eq (save-excursion (beginning-of-thing 'word)) 1))
+ (should (eq (save-excursion (end-of-thing 'word)) 11))
+ (goto-char (point-max))
+ ;; Look for a URL, using the second provider above.
+ (should (equal (bounds-of-thing-at-point 'url) '(12 . 19)))
+ (should (eq (save-excursion (beginning-of-thing 'url)) 12))
+ (should (eq (save-excursion (end-of-thing 'url)) 19))))
+
;;; thingatpt-tests.el ends here
--
2.25.1
