branch: elpa/beancount
commit bdd71c570df3466560260072a863e215f7d5ba1e
Author: Vladimir Kazanov <vkaza...@inbox.ru>
Commit: Daniele Nicolodi <dani...@grinta.net>
Implement xref backend
---
beancount-tests.el | 98 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
beancount.el | 68 +++++++++++++++++++++++++++++++++++++
2 files changed, 166 insertions(+)
diff --git a/beancount-tests.el b/beancount-tests.el
index 0ffd5c636f..fee1f486a1 100644
--- a/beancount-tests.el
+++ b/beancount-tests.el
@@ -16,6 +16,7 @@
(require 'ert)
+(require 'eieio)
(require 'beancount)
(require 'imenu)
@@ -350,3 +351,100 @@ known option nmaes."
(goto-char 0)
(beancount-date-down-day)
(should (equal (thing-at-point 'line) "2024-05-10\n"))))
+
+;;; Xref backend
+
+(defun beancount-test-xref-definition-pos (identifier position)
+ "Check if IDENTIFIER's position is the same is the same as
+POSITION provided by Beancount's xref-backend-definitions lookup."
+ (let ((defs (xref-backend-definitions 'beancount identifier)))
+ (should (equal (length defs) 1))
+ (let* ((def (car (xref-backend-definitions 'beancount identifier)))
+ (loc (xref-item-location def))
+ ;; Pre Emacs-28.1, defclass was used for
+ ;; xref-buffer-location.
+ (pos (if (version< emacs-version "28.1")
+ (oref loc position)
+ (xref-buffer-location-position loc))))
+ (should (equal pos position)))))
+
+(ert-deftest beancount/xref-backend-definitions ()
+ :tags '(xref)
+ (with-temp-buffer
+ (insert "
+2019-01-01 open Assets:Account1 TDB900
+2019-01-01 open Assets:Account2 TDB900
+2019-01-01 open Assets:Account3 TDB900
+
+2019-01-10 * \"Opening Balances\"
+ Equity:Opening-Balances
+ Assets:Account1 1.00 TDB900
+")
+ (beancount-test-xref-definition-pos "Assets:Account1" 2)
+ (beancount-test-xref-definition-pos "Assets:Account2" 41)
+ (beancount-test-xref-definition-pos "Assets:Account3" 80)))
+
+(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 ()
+ :tags '(xref)
+ ;; Creating Xref file locations assumes a buffer backed by a file.
+ (beancount-with-temp-file
+ (insert "
+2019-01-01 open Assets:Account1 TDB900
+2019-01-01 open Assets:Account2 TDB900
+2019-01-01 open Assets:Account3 TDB900
+
+2019-01-10 * \"Opening Balances\"
+ Equity:Opening-Balances
+ Assets:Account1 1.00 TDB900
+ Assets:Account2 2.00 TDB900
+
+2019-01-10 * \"More Balances\"
+ Equity:Opening-Balances
+ Assets:Account1 1.00 TDB900
+
+")
+ (should (equal (length (xref-backend-references 'beancount
"Assets:Account1")) 3))
+ (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-apropos ()
+ :tags '(xref)
+ ;; Creating Xref file locations assumes a buffer backed by a file.
+ (beancount-with-temp-file
+ (insert "
+2019-01-01 open Assets:Account1 TDB900
+2019-01-01 open Assets:Account2 TDB900
+2019-01-01 open Assets:Account3 TDB900
+
+2019-01-10 * \"Opening Balances\"
+ Equity:Opening-Balances
+ Assets:Account1 1.00 TDB900
+ Assets:Account2 2.00 TDB900
+
+2019-01-10 * \"More Balances\"
+ Equity:Opening-Balances
+ Assets:Account1 1.00 TDB900
+
+")
+ (should (equal (length (xref-backend-apropos 'beancount "Assets")) 6))
+ (should (equal (length (xref-backend-apropos 'beancount "Assets Account"))
6))
+ (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))))
diff --git a/beancount.el b/beancount.el
index fd18248611..a893b75f81 100644
--- a/beancount.el
+++ b/beancount.el
@@ -35,6 +35,8 @@
(require 'outline)
(require 'thingatpt)
(require 'cl-lib)
+(require 'xref)
+(require 'apropos)
;;;###autoload
(add-to-list 'auto-mode-alist '("\\.beancount\\'" . beancount-mode))
@@ -259,6 +261,11 @@ from the open directive for the relevant account."
(defconst beancount-metadata-regexp
"^\\s-+\\([a-z][A-Za-z0-9_-]+:\\)\\s-+\\(.+\\)")
+(defconst beancount-open-directive-regexp
+ (concat "^\\(" beancount-date-regexp "\\) +"
+ "\\(open\\) +"
+ "\\(" beancount-account-regexp "\\)"))
+
;; This is a grouping regular expression because the subexpression is
;; used in determining the outline level in `beancount-outline-level'.
(defvar beancount-outline-regexp "\\(;;;+\\|\\*+\\)")
@@ -402,6 +409,7 @@ are reserved for the mode anyway.)")
(setq-local outline-regexp beancount-outline-regexp)
(setq-local outline-level #'beancount-outline-level)
+ (setq-local xref-backend-functions #'beancount-xref-backend)
(setq imenu-generic-expression
(list (list nil (concat "^" beancount-outline-regexp "\\s-+\\(.*\\)$")
2))))
@@ -1248,5 +1256,65 @@ Essentially a much simplified version of `next-line'."
(if-let ((url (string-match "Running Fava on \\(http://.+:[0-9]+\\)\n"
output)))
(browse-url (match-string 1 output))))
+;;; Xref backend
+
+(defun beancount-xref-backend ()
+ "Beancount Xref backend."
+ 'beancount)
+
+(cl-defmethod xref-backend-definitions ((_ (eql beancount)) identifier)
+ "Find definitions of IDENTIFIER."
+ (let ((buf (current-buffer)))
+ (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)))))
+
+(cl-defmethod xref-backend-references ((_ (eql beancount)) identifier)
+ "Find references of IDENTIFIER."
+ (let ((fname (buffer-file-name)))
+ (cl-loop
+ for (ref-id . ref-pos) in
+ (beancount-collect-pos-alist beancount-account-regexp 0)
+ if (equal ref-id identifier)
+ collect
+ (xref-make ref-id
+ (xref-make-file-location
+ fname (line-number-at-pos ref-pos) 0)))))
+
+;; NOTE: This is a backport from Emacs 27 and newer versions. Can be
+;; removed once beancount-mode no longer supports Emacs 26.
+(defun beancount-xref-apropos-regexp (pattern)
+ "Return an Emacs regexp from PATTERN similar to `apropos'."
+ (apropos-parse-pattern
+ (if (string-equal (regexp-quote pattern) pattern)
+ ;; Split into words
+ (or (split-string pattern "[ \t]+" t)
+ (user-error "No word list given"))
+ pattern)))
+
+(cl-defmethod xref-backend-apropos ((_ (eql beancount)) pattern)
+ "Find all symbols that match PATTERN string."
+ (let ((pattern-re (beancount-xref-apropos-regexp pattern))
+ (fname (buffer-file-name)))
+ (cl-loop
+ for (ref-id . ref-pos) in
+ (beancount-collect-pos-alist beancount-account-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))
+
+(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)))
+
(provide 'beancount)
;;; beancount.el ends here
