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.

See <https://lists.gnu.org/archive/html/emacs-devel/2024-02/msg00200.html>.

* 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.

(cherry picked from commit ae9045a8bd8d3917feb570adfab0b929b120a8e5)

diff --git a/etc/NEWS b/etc/NEWS
index 65bddef30608393dde01dd4ac994f17f249f7093..c75f7ee9135394a00df582dd63057367b5429e40 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1825,19 +1825,34 @@ By default it retains the previous behavior: read the contents of
 Gemfile and act accordingly.  But you can also set it to t or nil to
 skip the check.
 
-** 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 ceafca282c414613793322e1c8f4cd87775c61ab..ff502914eb53672bc808e23a843eaa880218b3fd 100644 (file)
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -1336,9 +1336,16 @@ within text input fields."
   ;; 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)
@@ -1373,7 +1380,15 @@ within text input fields."
 
 (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 977a3d72cb79a7c9f668aa6d077036cc707aa199..be162cf9e117e935954f6f49027617ded69c2ab9 100644 (file)
--- a/lisp/progmodes/bug-reference.el
+++ b/lisp/progmodes/bug-reference.el
@@ -658,19 +658,39 @@ have been run, the auto-setup is inhibited.")
 
 (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 7896ad984df716700af8d44261f7053a13d6c82b..825f49cfab76b28d28cc54bfc0f0997f0aa4de1e 100644 (file)
--- a/lisp/thingatpt.el
+++ b/lisp/thingatpt.el
@@ -75,6 +75,27 @@ question.
 `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 @@ THING should be a symbol specifying a type of syntactic entity.
 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 @@ valid THING.
 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 @@ treated as white space."
       (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 e50738f1122513c6b39cd216c52b0e15c425d981..88a4bc8a27da805274fc615b683382ad0fe15d70 100644 (file)
--- a/test/lisp/thingatpt-tests.el
+++ b/test/lisp/thingatpt-tests.el
@@ -258,4 +258,63 @@ position to retrieve THING.")
   (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