Implement xref backend

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))))

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