procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Allow defining custom providers for more "thingatpt" functions

Browse source 
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.
This commit is contained in:
Jim Porter 2024-04-28 21:19:53 -07:00
parent a1b24ebc83
commit ae9045a8bd
5 changed files with 198 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
etc/NEWS
View file

@ -1735,6 +1735,26 @@ 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.
** Thingatpt
---
*** 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
---
@ -1743,11 +1763,6 @@ 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.
---
*** '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.
+++
*** New user option 'rcirc-log-time-format'.
This allows for rcirc logs to use a custom timestamp format, than the

21
lisp/net/eww.el
View file

@ -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)

26
lisp/progmodes/bug-reference.el
View file

@ -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)))))

83
lisp/thingatpt.el
View file

@ -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

59
test/lisp/thingatpt-tests.el
View file

@ -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