From a0ed62aa42fa47043511ba814cf5ce8419e9d03f 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 (bounds-of-thing-at-point-provider-alist) (forward-thing-provider-alist): New variables... (forward-thing, bounds-of-thing-at-point): ... 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 | 18 +++++++++++++----- lisp/thingatpt.el | 35 ++++++++++++++++++++++++++++++----- test/lisp/thingatpt-tests.el | 31 +++++++++++++++++++++++++++++++ 3 files changed, 74 insertions(+), 10 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 7efb4110bcd..2480f0d096d 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1591,19 +1591,27 @@ 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 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. --- *** '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/thingatpt.el b/lisp/thingatpt.el index 7896ad984df..d5f71e3c6a8 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -75,6 +75,22 @@ thing-at-point-provider-alist `existing-filename', `url', `email', `uuid', `word', `sentence', `whitespace', `line', `face' and `page'.") +(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 in much the same way as +`thing-at-point-provider-alist' (which see).") + +(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. The first provider for the \"thing\" that returns a +non-nil value wins. You can use this in much the same way as +`thing-at-point-provider-alist' (which see).") + ;; Basic movement ;;;###autoload @@ -84,11 +100,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 +127,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. diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index e50738f1122..4aacd776176 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -258,4 +258,35 @@ 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 () "test")))) + (insert "hello") + (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) (goto-char 4))))) + (insert "hello there") + (goto-char (point-min)) + (should (eq (save-excursion (forward-thing 'url) (point)) 4)) + (should (eq (save-excursion (forward-thing 'word) (point)) 6)))) + +(ert-deftest bounds-of-thing-at-point-providers () + (with-temp-buffer + (setq-local bounds-of-thing-at-point-provider-alist + `((url . ,(lambda () '(2 . 3))))) + (insert "hello") + ;; Look for a "URL", using our provider above. + (should (equal (bounds-of-thing-at-point 'url) '(2 . 3))) + (should (eq (save-excursion (beginning-of-thing 'url)) 2)) + (should (eq (save-excursion (end-of-thing 'url)) 3)) + ;; Look for a word, which should *not* use our provider above. + (should (equal (bounds-of-thing-at-point 'word) '(1 . 6))) + (should (eq (save-excursion (beginning-of-thing 'word)) 1)) + (should (eq (save-excursion (end-of-thing 'word)) 6)))) + ;;; thingatpt-tests.el ends here -- 2.25.1