From: Jim Porter <jporterbugs@gmail.com>
To: Ihor Radchenko <yantar92@posteo.net>
Cc: eliz@gnu.org, emacs-devel@gnu.org, emacs-orgmode@gnu.org
Subject: Re: Adding custom providers for thingatpt.el (was: [PATCH] Add support for 'thing-at-point' to get URL at point)
Date: Tue, 30 Apr 2024 11:27:04 -0700 [thread overview]
Message-ID: <2f344439-d0d6-a3e5-963c-773bb5c833d6@gmail.com> (raw)
In-Reply-To: <87sez36pvl.fsf@localhost>
[-- Attachment #1: Type: text/plain, Size: 847 bytes --]
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.)
[-- Attachment #2: 0001-Allow-defining-custom-providers-for-more-thingatpt-f.patch --]
[-- Type: text/plain, Size: 14978 bytes --]
From da26f0160c955f15e123e5b28cf8a9f514395e21 Mon Sep 17 00:00:00 2001
From: Jim Porter <jporterbugs@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
next prev parent reply other threads:[~2024-04-30 18:28 UTC|newest]
Thread overview: 24+ messages / expand[flat|nested] mbox.gz Atom feed top
2023-11-06 19:45 [PATCH] Add support for 'thing-at-point' to get URL at point Jim Porter
2023-11-06 19:56 ` Jim Porter
2023-11-06 20:11 ` Adding custom providers for thingatpt.el (was: [PATCH] Add support for 'thing-at-point' to get URL at point) Ihor Radchenko
2023-11-06 20:53 ` Jim Porter
2024-02-05 15:07 ` Ihor Radchenko
2024-02-05 22:44 ` Jim Porter
2024-02-05 22:56 ` Ihor Radchenko
2024-02-06 12:26 ` Eli Zaretskii
2024-02-06 12:38 ` Ihor Radchenko
2024-02-06 12:47 ` Eli Zaretskii
2024-04-12 12:41 ` Ihor Radchenko
2024-04-12 22:30 ` Jim Porter
2024-04-29 4:26 ` Jim Porter
2024-04-29 18:14 ` Ihor Radchenko
2024-04-30 4:42 ` Jim Porter
2024-04-30 11:39 ` Ihor Radchenko
2024-04-30 18:27 ` Jim Porter [this message]
2024-04-30 21:10 ` [External] : " Drew Adams
2024-05-07 1:08 ` Jim Porter
2024-05-07 1:52 ` Drew Adams
2024-05-07 12:20 ` Eli Zaretskii
2024-05-07 15:16 ` Drew Adams
2024-05-07 16:10 ` Jim Porter
2024-05-07 18:01 ` Eli Zaretskii
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.orgmode.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=2f344439-d0d6-a3e5-963c-773bb5c833d6@gmail.com \
--to=jporterbugs@gmail.com \
--cc=eliz@gnu.org \
--cc=emacs-devel@gnu.org \
--cc=emacs-orgmode@gnu.org \
--cc=yantar92@posteo.net \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).