Skip to content

Commit

Permalink
tags and links support for xref definitions/references/apropos
Browse files Browse the repository at this point in the history
  • Loading branch information
@vkazanov
vkazanov committed Jun 18, 2024
1 parent 0a242af commit 146b84d
Show file tree
Hide file tree
Showing 2 changed files with 141 additions and 27 deletions.
104 changes: 89 additions & 15 deletions beancount-tests.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 "
Expand All @@ -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
Expand All @@ -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.
Expand All @@ -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
Expand All @@ -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))))
64 changes: 52 additions & 12 deletions beancount.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -37,6 +37,7 @@
(require 'cl-lib)
(require 'xref)
(require 'apropos)
(require 'rx)

;;;###autoload
(add-to-list 'auto-mode-alist '("\\.beancount\\'" . beancount-mode))
Expand Down Expand Up @@ -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) ";")
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand All @@ -1301,20 +1339,22 @@ 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
(xref-make-file-location
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

0 comments on commit 146b84d

Please sign in to comment.