From 146b84da97f20a78c4a1a71026da7f25b882c5b9 Mon Sep 17 00:00:00 2001 From: Vladimir Kazanov Date: Tue, 18 Jun 2024 16:37:29 +0100 Subject: [PATCH] tags and links support for xref definitions/references/apropos --- beancount-tests.el | 104 ++++++++++++++++++++++++++++++++++++++------- beancount.el | 64 ++++++++++++++++++++++------ 2 files changed, 141 insertions(+), 27 deletions(-) diff --git a/beancount-tests.el b/beancount-tests.el index 26a86ee..6b07085 100644 --- a/beancount-tests.el +++ b/beancount-tests.el @@ -368,7 +368,7 @@ POSITION provided by Beancount's xref-backend-definitions lookup." (xref-buffer-location-position loc)))) (should (equal pos position))))) -(ert-deftest beancount/xref-backend-definitions () +(ert-deftest beancount/xref-backend-definitions-accounts () :tags '(xref) (with-temp-buffer (insert " @@ -384,23 +384,54 @@ POSITION provided by Beancount's xref-backend-definitions lookup." (beancount-test-xref-definition-pos "Assets:Account2" 41) (beancount-test-xref-definition-pos "Assets:Account3" 80))) +(ert-deftest beancount/xref-backend-definitions-tags () + :tags '(xref) + (with-temp-buffer + (insert " +2019-01-10 * \"Opening Balances\" #tag1 + Equity:Opening-Balances + Assets:Account1 1.00 TDB900 + +2019-01-10 * \"Opening Balances\" #tag2 + Equity:Opening-Balances + Assets:Account1 1.00 TDB900 +") + (beancount-test-xref-definition-pos "#tag1" 35) + (beancount-test-xref-definition-pos "#tag2" 138))) + +(ert-deftest beancount/xref-backend-definitions-links () + :tags '(xref) + (with-temp-buffer + (insert " +2019-01-10 * \"Opening Balances\" #link1 + Equity:Opening-Balances + Assets:Account1 1.00 TDB900 + +2019-01-10 * \"Opening Balances\" #link2 + Equity:Opening-Balances + Assets:Account1 1.00 TDB900 +") + (beancount-test-xref-definition-pos "#link1" 35) + (beancount-test-xref-definition-pos "#link2" 139))) + + (defmacro beancount-with-temp-file (&rest body) "Generate a temporary file and open it as a current buffer. Run BODY forms in the buffer's context. Remove both the buffer and a backing file having completed the test." (declare (indent 1)) `(let ((file (make-temp-file "beancount-test-")) - buf) - (unwind-protect - (progn (setq buf (find-file-literally file)) - ,@body) - (ignore-errors (delete-file file)) - (ignore-errors - (with-current-buffer buf - (set-buffer-modified-p nil)) - (kill-buffer buf))))) - -(ert-deftest beancount/xref-backend-references () + buf) + (unwind-protect + (progn (setq buf (find-file-literally file)) + ,@body) + (ignore-errors (delete-file file)) + (ignore-errors + (with-current-buffer buf + (set-buffer-modified-p nil)) + (kill-buffer buf))))) + +(ert-deftest beancount/xref-backend-references-accounts () :tags '(xref) ;; Creating Xref file locations assumes a buffer backed by a file. (beancount-with-temp-file @@ -423,6 +454,46 @@ and a backing file having completed the test." (should (equal (length (xref-backend-references 'beancount "Assets:Account2")) 2)) (should (equal (length (xref-backend-references 'beancount "Assets:Account3")) 1)))) +(ert-deftest beancount/xref-backend-references-tags () + :tags '(xref) + ;; Creating Xref file locations assumes a buffer backed by a file. + (beancount-with-temp-file + (insert " +2019-01-10 * \"More Balances\" #tag1 + Equity:Opening-Balances + Assets:Account1 1.00 TDB900 + +2019-01-10 * \"Opening Balances\" #tag2 + Assets:Account1 1.00 TDB900 + Assets:Account2 2.00 TDB900 + +2019-01-10 * \"More Balances\" #tag2 + Equity:Opening-Balances + Assets:Account1 1.00 TDB900 +") + (should (equal (length (xref-backend-references 'beancount "#tag1")) 1)) + (should (equal (length (xref-backend-references 'beancount "#tag2")) 2)))) + +(ert-deftest beancount/xref-backend-references-links () + :tags '(xref) + ;; Creating Xref file locations assumes a buffer backed by a file. + (beancount-with-temp-file + (insert " +2019-01-10 * \"More Balances\" ^link1 + Equity:Opening-Balances + Assets:Account1 1.00 TDB900 + +2019-01-10 * \"Opening Balances\" ^link1 + Assets:Account1 1.00 TDB900 + Assets:Account2 2.00 TDB900 + +2019-01-10 * \"More Balances\" ^link2 + Equity:Opening-Balances + Assets:Account1 1.00 TDB900 +") + (should (equal (length (xref-backend-references 'beancount "^link1")) 2)) + (should (equal (length (xref-backend-references 'beancount "^link2")) 1)))) + (ert-deftest beancount/xref-backend-apropos () :tags '(xref) ;; Creating Xref file locations assumes a buffer backed by a file. @@ -432,12 +503,12 @@ and a backing file having completed the test." 2019-01-01 open Assets:Account2 TDB900 2019-01-01 open Assets:Account3 TDB900 -2019-01-10 * \"Opening Balances\" +2019-01-10 * \"Opening Balances\" #tag ^link1 Equity:Opening-Balances Assets:Account1 1.00 TDB900 Assets:Account2 2.00 TDB900 -2019-01-10 * \"More Balances\" +2019-01-10 * \"More Balances\" #tag ^link2 Equity:Opening-Balances Assets:Account1 1.00 TDB900 @@ -447,4 +518,7 @@ and a backing file having completed the test." (should (equal (length (xref-backend-apropos 'beancount "Assets Account1")) 3)) (should (equal (length (xref-backend-apropos 'beancount "Equity")) 2)) (should (equal (length (xref-backend-apropos 'beancount "Opening")) 2)) - (should (equal (length (xref-backend-apropos 'beancount "Opening Assets")) 0)))) + (should (equal (length (xref-backend-apropos 'beancount "Opening Assets")) 0)) + (should (equal (length (xref-backend-apropos 'beancount "tag")) 2)) + (should (equal (length (xref-backend-apropos 'beancount "link1")) 1)) + (should (equal (length (xref-backend-apropos 'beancount "link2")) 1)))) diff --git a/beancount.el b/beancount.el index b0ed7a9..00ffb15 100644 --- a/beancount.el +++ b/beancount.el @@ -37,6 +37,7 @@ (require 'cl-lib) (require 'xref) (require 'apropos) +(require 'rx) ;;;###autoload (add-to-list 'auto-mode-alist '("\\.beancount\\'" . beancount-mode)) @@ -270,6 +271,12 @@ from the open directive for the relevant account." ;; used in determining the outline level in `beancount-outline-level'. (defvar beancount-outline-regexp "\\(;;;+\\|\\*+\\)") +;; Regular expression for all symbols recognised by the Xref backend. +(defconst beancount-xref-symbol-regexp + (rx-to-string `(or (regexp ,beancount-account-regexp) + (regexp ,(concat "#[" beancount-tag-chars "]+")) + (regexp ,(concat "\\^[" beancount-tag-chars "]+"))))) + (defun beancount-outline-level () (let ((len (- (match-end 1) (match-beginning 1)))) (if (string-equal (substring (match-string 1) 0 1) ";") @@ -1021,6 +1028,12 @@ Only useful if you have not installed Beancount properly in your PATH.") (put 'beancount-link 'bounds-of-thing-at-point #'beancount--bounds-of-link-at-point) +(defun beancount--bounds-of-tag-at-point () + (when (thing-at-point-looking-at (concat "\\#[" beancount-tag-chars "]+") 128) + (cons (match-beginning 0) (match-end 0)))) + +(put 'beancount-tag 'bounds-of-thing-at-point #'beancount--bounds-of-tag-at-point) + (defun beancount-linked () "Get the \"linked\" info from `beancount-doctor-program'." (interactive) @@ -1264,20 +1277,45 @@ Essentially a much simplified version of `next-line'." (cl-defmethod xref-backend-definitions ((_ (eql beancount)) identifier) "Find definitions of IDENTIFIER." - (let ((buf (current-buffer))) + (let ((buf (current-buffer)) + re mgroup) + (cond + ;; tag + ((string-prefix-p "#" identifier) + (setq re (concat "#[" beancount-tag-chars "]+")) + (setq mgroup 0)) + ;; link + ((string-prefix-p "^" identifier) + (setq re (concat "\\^[" beancount-tag-chars "]+")) + (setq mgroup 0)) + ;; account + (t + (setq re beancount-open-directive-regexp) + (setq mgroup 3))) (cl-loop - for (def-id . def-pos) in - (beancount-collect-pos-alist beancount-open-directive-regexp 3) - if (equal def-id identifier) - collect - (xref-make def-id (xref-make-buffer-location buf def-pos))))) + for (def-id . def-pos) in + (beancount-collect-pos-alist re mgroup) + if (equal def-id identifier) + collect + (xref-make def-id (xref-make-buffer-location buf def-pos))))) (cl-defmethod xref-backend-references ((_ (eql beancount)) identifier) "Find references of IDENTIFIER." - (let ((fname (buffer-file-name))) + (let ((fname (buffer-file-name)) + re) + (setq re + (cond + ;; tag + ((string-prefix-p "#" identifier) + (concat "#[" beancount-tag-chars "]+")) + ;; link + ((string-prefix-p "^" identifier) + (concat "\\^[" beancount-tag-chars "]+")) + ;; account + (t beancount-account-regexp))) (cl-loop for (ref-id . ref-pos) in - (beancount-collect-pos-alist beancount-account-regexp 0) + (beancount-collect-pos-alist re 0) if (equal ref-id identifier) collect (xref-make ref-id @@ -1301,7 +1339,7 @@ Essentially a much simplified version of `next-line'." (fname (buffer-file-name))) (cl-loop for (ref-id . ref-pos) in - (beancount-collect-pos-alist beancount-account-regexp 0) + (beancount-collect-pos-alist beancount-xref-symbol-regexp 0) if (string-match-p pattern-re ref-id) collect (xref-make ref-id @@ -1309,12 +1347,14 @@ Essentially a much simplified version of `next-line'." fname (line-number-at-pos ref-pos) 0))))) (cl-defmethod xref-backend-identifier-completion-table ((_ (eql beancount))) - (beancount-get-account-names)) + (beancount-collect-unique beancount-xref-symbol-regexp 0)) (cl-defmethod xref-backend-identifier-at-point ((_ (eql beancount))) "Extract a symbol at point, check if it is an account, return it" - (when-let ((acc (thing-at-point 'beancount-account))) - (substring-no-properties acc))) + (when-let ((thing (or (thing-at-point 'beancount-account) + (thing-at-point 'beancount-link) + (thing-at-point 'beancount-tag)))) + (substring-no-properties thing))) (provide 'beancount) ;;; beancount.el ends here