From ad8db930907cd760142fd6f035d97ce93ce8d850 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 * 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. (forward-thing-for-text-property) (bounds-of-thing-at-point-for-text-property): New functions. * lisp/net/eww.el (eww--bounds-of-url-at-point, eww--forward-url): New functions... (eww-mode): ... use them. * lisp/progmodes/bug-reference.el (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 | 21 +++++++--- lisp/net/eww.el | 14 +++++++ lisp/progmodes/bug-reference.el | 22 +++++++++- lisp/thingatpt.el | 71 ++++++++++++++++++++++++++++++--- test/lisp/thingatpt-tests.el | 36 +++++++++++++++++ 5 files changed, 153 insertions(+), 11 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 7efb4110bcd..394f75884c1 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1591,19 +1591,30 @@ of the currently existing keyboards macros using the new mode duplicating them, deleting them, and editing their counters, formats, and keys. -** Miscellaneous +** thingatpt.el --- -*** 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 and functions 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. In +addition, "things" defined by a text property can use the new functions +'bounds-of-thing-at-point-for-text-property' and +'forward-thing-for-text-property' to help implement these providers. --- *** '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..adabd8d8d8b 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -1321,6 +1321,12 @@ eww-mode (setq-local thing-at-point-provider-alist (append thing-at-point-provider-alist '((url . eww--url-at-point)))) + (setq-local bounds-of-thing-at-point-provider-alist + (append bounds-of-thing-at-point-provider-alist + '((url . eww--bounds-of-url-at-point)))) + (setq-local forward-thing-provider-alist + (append forward-thing-provider-alist + '((url . eww--forward-url)))) (setq-local bookmark-make-record-function #'eww-bookmark-make-record) (buffer-disable-undo) (setq-local shr-url-transformer #'eww--transform-url) @@ -1351,6 +1357,14 @@ eww--url-at-point "`thing-at-point' provider function." (get-text-property (point) 'shr-url)) +(defun eww--bounds-of-url-at-point () + "`bounds-of-thing-at-point' provider function." + (bounds-of-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)) + ;;;###autoload (defun eww-browse-url (url &optional new-window) "Ask the EWW browser to load URL. diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index 977a3d72cb7..bfc22fb10d2 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -660,17 +660,37 @@ bug-reference--url-at-point "`thing-at-point' provider function." (get-char-property (point) 'bug-reference-url)) +(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--forward-url (n) + "`forward-thing' provider function." + (forward-thing-for-text-property 'bug-reference-url n)) + (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))))) + '((url . bug-reference--url-at-point)))) + (setq-local bounds-of-thing-at-point-provider-alist + (append bounds-of-thing-at-point-provider-alist + '((url . bug-reference--bounds-of-url-at-point)))) + (setq-local forward-thing-provider-alist + (append forward-thing-provider-alist + '((url . bug-reference--forward-url))))) (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 bounds-of-thing-at-point-provider-alist + (delete '((url . bug-reference--bounds-of-url-at-point)) + bounds-of-thing-at-point-provider-alist)) + (setq forward-thing-provider-alist + (delete '((url . bug-reference--forward-url)) + forward-thing-provider-alist)) (save-restriction (widen) (bug-reference-unfontify (point-min) (point-max))))) diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 7896ad984df..dad71a4ca94 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,35 @@ list-at-point (goto-char (or (nth 8 ppss) (point))) (form-at-point 'list 'listp)))) +(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." + (when (get-text-property (point) property) + (cons (or (previous-single-property-change + (min (1+ (point)) (point-max)) property) + (point-min)) + (or (next-single-property-change (point) property) + (point-max))))) + ;;; thingatpt.el ends here diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index e50738f1122..26e20f58be7 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -258,4 +258,40 @@ 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 () (get-text-property (point) 'my-url))))) + (insert (propertize "hello" 'my-url "test")) + (goto-char (point-min)) + (should (equal (thing-at-point 'url) "test")) + (should (equal (thing-at-point 'word) "hello")))) + +(ert-deftest forward-thing-providers () + (with-temp-buffer + (setq-local forward-thing-provider-alist + `((url . ,(lambda (n) + (forward-thing-for-text-property 'my-url n))))) + (insert (propertize "foo" 'my-url "test") "bar") + (goto-char (point-min)) + (should (eq (save-excursion (forward-thing 'url) (point)) 4)) + (should (eq (save-excursion (forward-thing 'word) (point)) 7)))) + +(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 + 'my-url))))) + (insert (propertize "foo" 'my-url "test") "bar") + (goto-char (point-min)) + ;; Look for a "URL", using our provider above. + (should (equal (bounds-of-thing-at-point 'url) '(1 . 4))) + (should (eq (save-excursion (beginning-of-thing 'url)) 1)) + (should (eq (save-excursion (end-of-thing 'url)) 4)) + ;; Look for a word, which should *not* use our provider above. + (should (equal (bounds-of-thing-at-point 'word) '(1 . 7))) + (should (eq (save-excursion (beginning-of-thing 'word)) 1)) + (should (eq (save-excursion (end-of-thing 'word)) 7)))) + ;;; thingatpt-tests.el ends here -- 2.25.1