From da26f0160c955f15e123e5b28cf8a9f514395e21 Mon Sep 17 00:00:00 2001 From: Jim Porter 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