;;; beancount.el --- A major mode to edit Beancount input files. -*- lexical-binding: t -*- ;; Copyright (C) 2013 Martin Blais ;; Copyright (C) 2015 Free Software Foundation, Inc. ;; Copyright (C) 2019 Daniele Nicolodi ;; Version: 0.9.0 ;; Author: Martin Blais ;; Author: Stefan Monnier ;; Author: Daniele Nicolodi ;; This file is not part of GNU Emacs. ;; This package is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This package is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this package. If not, see . ;;; Commentary: ;; TODO: Add a flymake rule, using bean-check ;;; Code: (autoload 'ido-completing-read "ido") (require 'subr-x) (require 'outline) (require 'thingatpt) (require 'cl-lib) (require 'xref) (require 'apropos) (require 'rx) ;;;###autoload (add-to-list 'auto-mode-alist '("\\.beancount\\'" . beancount-mode)) (defgroup beancount () "Editing mode for Beancount files." :group 'beancount) (defcustom beancount-transaction-indent 2 "Transaction indent." :type 'integer) (defcustom beancount-number-alignment-column 52 "Column to which align numbers in posting definitions. Set to 0 to automatically determine the minimum column that will allow to align all amounts." :type 'integer) (defcustom beancount-highlight-transaction-at-point nil "If t highlight transaction under point." :type 'boolean) (defcustom beancount-use-ido t "If non-nil, use ido-style completion rather than the standard." :type 'boolean) (defcustom beancount-electric-currency nil "If non-nil, make `newline' try to add missing currency to complete the posting at point. The correct currency is determined from the open directive for the relevant account." :type 'boolean) (defgroup beancount-faces nil "Beancount mode highlighting" :group 'beancount) (defface beancount-directive '((t :inherit font-lock-keyword-face)) "Face for Beancount directives.") (defface beancount-tag '((t :inherit font-lock-type-face)) "Face for Beancount tags.") (defface beancount-link '((t :inherit font-lock-type-face)) "Face for Beancount links.") (defface beancount-date '((t :inherit font-lock-constant-face)) "Face for Beancount dates.") (defface beancount-account '((t :inherit font-lock-builtin-face)) "Face for Beancount account names.") (defface beancount-amount '((t :inherit default)) "Face for Beancount amounts.") (defface beancount-narrative '((t :inherit font-lock-builtin-face)) "Face for Beancount transactions narrative.") (defface beancount-narrative-cleared '((t :inherit font-lock-string-face)) "Face for Beancount cleared transactions narrative.") (defface beancount-narrative-pending '((t :inherit font-lock-keyword-face)) "Face for Beancount pending transactions narrative.") (defface beancount-metadata '((t :inherit font-lock-type-face)) "Face for Beancount metadata.") (defface beancount-highlight '((t :inherit highlight)) "Face to highlight Beancount transaction at point.") (defface beancount-outline-1 '((t :inherit outline-1)) "Outline level 1.") (defface beancount-outline-2 '((t :inherit outline-2)) "Outline level 2.") (defface beancount-outline-3 '((t :inherit outline-3)) "Outline level 3.") (defface beancount-outline-4 '((t :inherit outline-4)) "Outline level 4.") (defface beancount-outline-5 '((t :inherit outline-5)) "Outline level 5.") (defface beancount-outline-6 '((t :inherit outline-6)) "Outline level 6.") (defface beancount-outline-7 '((t :inherit outline-7)) "Outline level 7.") (defface beancount-outline-8 '((t :inherit outline-8)) "Outline level 8.") (defconst beancount-account-directive-names '("balance" "close" "document" "note" "open" "pad") "Directive names that can appear after a date and are followd by an account.") (defconst beancount-no-account-directive-names '("commodity" "event" "price" "query" "txn") "Directives with a date but without an account. List of directive names that can appear after a date and that are _not_ followed by an account.") (defconst beancount-timestamped-directive-names (append beancount-account-directive-names beancount-no-account-directive-names) "Directive names that can appear after a date.") (defconst beancount-directive-names '("include" "option" "plugin" "poptag" "pushtag") "Directive names that can appear at the beginning of a line.") (defconst beancount-account-categories '("Assets" "Liabilities" "Equity" "Income" "Expenses")) (defconst beancount-tag-chars "[:alnum:]-_/.") (defconst beancount-account-chars "[:alnum:]-_:") (defconst beancount-option-names ;; This list is kept in sync with the options defined in ;; beancount/parser/options.py. '("account_current_conversions" "account_current_earnings" "account_previous_balances" "account_previous_conversions" "account_previous_earnings" "account_rounding" "account_unrealized_gains" "allow_deprecated_none_for_tags_and_links" "allow_pipe_separator" "booking_method" "conversion_currency" "display_precision" "documents" "infer_tolerance_from_cost" "inferred_tolerance_default" "inferred_tolerance_multiplier" "insert_pythonpath" "long_string_maxlines" "name_assets" "name_equity" "name_expenses" "name_income" "name_liabilities" "operating_currency" "plugin_processing_mode" "render_commas" "title" "tolerance_multiplier")) (defconst beancount-date-regexp "[0-9]\\{4\\}[-/][0-9]\\{2\\}[-/][0-9]\\{2\\}" "A regular expression to match dates.") (defconst beancount-account-regexp (concat (regexp-opt beancount-account-categories) "\\(?::[[:upper:][:digit:]][[:alnum:]-_]*\\)+") "A regular expression to match account names.") (defconst beancount-number-regexp "[-+]?[0-9]+\\(?:,[0-9]\\{3\\}\\)*\\(?:\\.[0-9]*\\)?" "A regular expression to match decimal numbers.") (defconst beancount-currency-regexp "[A-Z][A-Z-_'.]*" "A regular expression to match currencies.") (defconst beancount-flag-regexp ;; Single character: Certain symbols plus uppercase letters. ;; case-fold-search t will cause a single lowercase letter to match also. "[!#%&*?A-Z]") (defconst beancount-transaction-regexp (concat "^\\(" beancount-date-regexp "\\) +" "\\(\\(?:txn\\)\\|" beancount-flag-regexp "\\) +" "\\(\".*\"\\)")) (defconst beancount-posting-regexp (concat "^\\s-+" "\\(" beancount-account-regexp "\\)" "\\(?:\\s-+\\(\\(" beancount-number-regexp "\\)" "\\s-+\\(" beancount-currency-regexp "\\)\\)\\)?")) (defconst beancount-balance-regexp ;; The grouping in this regular expression matches the one in ;; `beancount-posting-regexp' to be used in amount align ;; machinery. See `beancount-align-number'. (concat "^" beancount-date-regexp "\\s-+balance\\s-+" "\\(" beancount-account-regexp "\\)\\s-+" "\\(\\(" beancount-number-regexp "\\)\\s-+\\(" beancount-currency-regexp "\\)\\)")) (defconst beancount-directive-regexp (concat "^\\(" (regexp-opt beancount-directive-names) "\\) +")) (defconst beancount-timestamped-directive-regexp (concat "^\\(" beancount-date-regexp "\\) +" "\\(" (regexp-opt beancount-timestamped-directive-names) "\\) +")) (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 "\\(;;;+\\|\\*+\\)") ;; 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) ";") (- len 2) len))) (defun beancount-face-by-state (state) (cond ((string-equal state "*") 'beancount-narrative-cleared) ((string-equal state "!") 'beancount-narrative-pending) (t 'beancount-narrative))) (defun beancount-outline-face () (if outline-minor-mode (cl-case (funcall outline-level) (1 'beancount-outline-1) (2 'beancount-outline-2) (3 'beancount-outline-3) (4 'beancount-outline-4) (5 'beancount-outline-5) (6 'beancount-outline-6) (7 'beancount-outline-7) (8 'beancount-outline-8) (otherwise nil)) nil)) (defvar beancount-font-lock-keywords `((,beancount-transaction-regexp (1 'beancount-date) (2 (beancount-face-by-state (match-string 2)) t) (3 (beancount-face-by-state (match-string 2)) t)) (,beancount-posting-regexp (1 'beancount-account) (2 'beancount-amount nil :lax)) (,beancount-metadata-regexp (1 'beancount-metadata) (2 'beancount-metadata t)) (,beancount-directive-regexp (1 'beancount-directive)) (,beancount-timestamped-directive-regexp (1 'beancount-date) (2 'beancount-directive)) ;; Fontify section headers when composed with outline-minor-mode. (,(concat "^\\(" beancount-outline-regexp "\\).*") (0 (beancount-outline-face))) ;; Tags and links. (,(concat "\\#[" beancount-tag-chars "]*") . 'beancount-tag) (,(concat "\\^[" beancount-tag-chars "]*") . 'beancount-link) ;; Accounts not covered by previous rules. (,beancount-account-regexp . 'beancount-account) ;; Number followed by currency not covered by previous rules. (,(concat beancount-number-regexp "\\s-+" beancount-currency-regexp) . 'beancount-amount) )) (defun beancount-tab-dwim (&optional arg) (interactive "P") (if (and outline-minor-mode (or arg (outline-on-heading-p))) (beancount-outline-cycle arg) (indent-for-tab-command))) (defvar beancount-mode-map-prefix [(control c)] "The prefix key used to bind Beancount commands in Emacs") (defvar beancount-mode-old-style-keybindings nil "*Set this to non-nil to continue using old-style keybindings. In mid-2023, `beancount-mode' changed the keybindings for many of its commands. This was because the old bindings violated the Emacs keybinding standards (see section \"Key Binding Conventions\" in the Emacs Lisp documentation). However, you might be accustomed to the old bindings and prefer to continue using them; this variable offers a convenient way to do so. If it is non-nil when `beancount.el' is loaded, then the old bindings will also be made available. (The new bindings will be left in place too, since the key sequences they use are reserved for the mode anyway.)") (defvar beancount-mode-map (let ((map (make-sparse-keymap)) (p beancount-mode-map-prefix)) (define-key map (kbd "TAB") #'beancount-tab-dwim) (define-key map (kbd "M-RET") #'beancount-insert-date) (define-key map (vconcat p [(\')]) #'beancount-insert-account) (define-key map (vconcat p [(control c)]) #'beancount-transaction-clear) (define-key map (vconcat p [(control f)]) #'beancount-transaction-flag) (define-key map (vconcat p [(control l)]) #'beancount-check) (define-key map (vconcat p [(control q)]) #'beancount-query) (define-key map (vconcat p [(control x)]) #'beancount-context) (define-key map (vconcat p [(control k)]) #'beancount-linked) (define-key map (vconcat p [(control r)]) #'beancount-region-default) (define-key map (vconcat p [(control t)]) #'beancount-region-value) (define-key map (vconcat p [(control y)]) #'beancount-region-cost) (define-key map (vconcat p [(control i)]) #'beancount-insert-prices) (define-key map (vconcat p [(left)]) #'beancount-date-down-day) (define-key map (vconcat p [(right)]) #'beancount-date-up-day) (define-key map (vconcat p [(\;)]) #'beancount-align-to-previous-number) (define-key map (vconcat p [(\:)]) #'beancount-align-numbers) (when beancount-mode-old-style-keybindings (define-key map [(control c)(control g)] #'beancount-transaction-clear) (define-key map [(control c)(l)] #'beancount-check) (define-key map [(control c)(q)] #'beancount-query) (define-key map [(control c)(x)] #'beancount-context) (define-key map [(control c)(k)] #'beancount-linked) (define-key map [(control c)(r)] #'beancount-region-default) (define-key map [(control c)(t)] #'beancount-region-value) (define-key map [(control c)(y)] #'beancount-region-cost) (define-key map [(control c)(p)] #'beancount-insert-prices)) map)) (defvar beancount-mode-syntax-table (let ((st (make-syntax-table))) (modify-syntax-entry ?\" "\"\"" st) (modify-syntax-entry ?\; "<" st) (modify-syntax-entry ?\n ">" st) st)) ;;;###autoload (define-derived-mode beancount-mode prog-mode "Beancount" "A mode for Beancount files. \\{beancount-mode-map}" :group 'beancount :syntax-table beancount-mode-syntax-table (setq-local paragraph-ignore-fill-prefix t) (setq-local fill-paragraph-function #'beancount-indent-transaction) (setq-local comment-start ";") (setq-local comment-start-skip ";+\\s-*") (setq-local comment-add 1) (setq-local indent-line-function #'beancount-indent-line) (setq-local indent-region-function #'beancount-indent-region) (setq-local indent-tabs-mode nil) (setq-local tab-always-indent 'complete) (setq-local completion-ignore-case t) (add-hook 'completion-at-point-functions #'beancount-completion-at-point nil t) (add-hook 'post-command-hook #'beancount-highlight-transaction-at-point nil t) (add-hook 'post-self-insert-hook #'beancount--electric-currency nil t) (setq-local font-lock-defaults '(beancount-font-lock-keywords)) (setq-local font-lock-syntax-table t) (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)))) (defun beancount-collect-pushed-tags (begin end) "Return list of all pushed (and not popped) tags in the region." (goto-char begin) (let ((tags (make-hash-table :test 'equal))) (while (re-search-forward (concat "^\\(push\\|pop\\)tag\\s-+\\(#[" beancount-tag-chars "]+\\)") end t) (if (string-equal (match-string 1) "push") (puthash (match-string-no-properties 2) nil tags) (remhash (match-string-no-properties 2) tags))) (hash-table-keys tags))) (defun beancount-goto-transaction-begin () "Move the cursor to the first line of the transaction definition." (interactive) (beginning-of-line) ;; everything that is indented with at lest one space or tab is part ;; of the transaction definition (while (looking-at-p "[ \t]+") (forward-line -1)) (point)) (defun beancount-goto-transaction-end () "Move the cursor to the line after the transaction definition." (interactive) (beginning-of-line) (if (looking-at-p beancount-transaction-regexp) (forward-line)) ;; everything that is indented with at least one space or tab as part ;; of the transaction definition (while (looking-at-p "[ \t]+") (forward-line)) (point)) (defun beancount-goto-next-transaction (&optional arg) "Move to the next transaction. With an argument move to the next non cleared transaction." (interactive "P") (beancount-goto-transaction-end) (let ((done nil)) (while (and (not done) (re-search-forward beancount-transaction-regexp nil t)) (if (and arg (string-equal (match-string 2) "*")) (goto-char (match-end 0)) (goto-char (match-beginning 0)) (setq done t))) (if (not done) (goto-char (point-max))))) (defun beancount-goto-previous-transaction (&optional arg) "Move to the previous transaction. With an argument move to the previous non cleared transaction." (interactive "P") (beancount-goto-transaction-begin) (let ((done nil)) (while (and (not done) (re-search-backward beancount-transaction-regexp nil t)) (if (and arg (string-equal (match-string 2) "*")) (goto-char (match-beginning 0)) (goto-char (match-beginning 0)) (setq done t))) (if (not done) (goto-char (point-min))))) (defun beancount-find-transaction-extents (p) (save-excursion (goto-char p) (list (beancount-goto-transaction-begin) (beancount-goto-transaction-end)))) (defun beancount-inside-transaction-p () (let ((bounds (beancount-find-transaction-extents (point)))) (> (- (cadr bounds) (car bounds)) 0))) (defun beancount-looking-at (regexp n pos) (and (looking-at regexp) (>= pos (match-beginning n)) (<= pos (match-end n)))) (defvar beancount-accounts nil "A list of the accounts available in this buffer.") (make-variable-buffer-local 'beancount-accounts) (defun beancount-completion-at-point () "Return the completion data relevant for the text at point." (save-excursion (save-match-data (let ((pos (point))) (beginning-of-line) (cond ;; non timestamped directive ((beancount-looking-at "[a-z]*" 0 pos) (list (match-beginning 0) (match-end 0) (mapcar (lambda (s) (concat s " ")) beancount-directive-names))) ;; poptag ((beancount-looking-at (concat "poptag\\s-+\\(\\(?:#[" beancount-tag-chars "]*\\)\\)") 1 pos) (list (match-beginning 1) (match-end 1) (beancount-collect-pushed-tags (point-min) (point)))) ;; option ((beancount-looking-at (concat "^option\\s-+\\(\"[a-z_]*\\)") 1 pos) (list (match-beginning 1) (match-end 1) (mapcar (lambda (s) (concat "\"" s "\" ")) beancount-option-names))) ;; timestamped directive ((beancount-looking-at (concat beancount-date-regexp "\\s-+\\([[:alpha:]]*\\)") 1 pos) (list (match-beginning 1) (match-end 1) (mapcar (lambda (s) (concat s " ")) beancount-timestamped-directive-names))) ;; timestamped directives followed by account ((beancount-looking-at (concat "^" beancount-date-regexp "\\s-+" (regexp-opt beancount-account-directive-names) "\\s-+\\([" beancount-account-chars "]*\\)") 1 pos) (setq beancount-accounts nil) (list (match-beginning 1) (match-end 1) #'beancount-account-completion-table)) ;; pad directive followed by two accounts ((beancount-looking-at (concat "^" beancount-date-regexp "\\s-+" (regexp-opt '("pad")) "\\s-+\\([" beancount-account-chars "]*\\)" "\\s-+\\([" beancount-account-chars "]*\\)") 2 pos) (setq beancount-accounts nil) (list (match-beginning 2) (match-end 2) #'beancount-account-completion-table)) ;; posting ((and (beancount-looking-at (concat "[ \t]+\\([" beancount-account-chars "]*\\)") 1 pos) ;; Do not force the account name to start with a ;; capital, so that it is possible to use substring ;; completion and we can rely on completion to fix ;; capitalization thanks to completion-ignore-case. (beancount-inside-transaction-p)) (setq beancount-accounts nil) (list (match-beginning 1) (match-end 1) #'beancount-account-completion-table)) ;; tags ((beancount-looking-at (concat "[ \t]+#\\([" beancount-tag-chars "]*\\)") 1 pos) (let* ((candidates nil) (regexp (concat "\\#\\([" beancount-tag-chars "]+\\)")) (completion-table (lambda (string pred action) (if (null candidates) (setq candidates (sort (beancount-collect-unique regexp 1) #'string<))) (complete-with-action action candidates string pred)))) (list (match-beginning 1) (match-end 1) completion-table))) ;; links ((beancount-looking-at (concat "[ \t]+\\^\\([" beancount-tag-chars "]*\\)") 1 pos) (let* ((candidates nil) (regexp (concat "\\^\\([" beancount-tag-chars "]+\\)")) (completion-table (lambda (string pred action) (if (null candidates) (setq candidates (sort (beancount-collect-unique regexp 1) #'string<))) (complete-with-action action candidates string pred)))) (list (match-beginning 1) (match-end 1) completion-table)))))))) (defun beancount-collect-pos-alist (regexp n) "Return a list of conses mapping matches of REGEXP group N in the current buffer to a position of the match beginning." (let ((pos (point))) (save-excursion (save-match-data (let (result) (goto-char (point-min)) (while (re-search-forward regexp nil t) ;; Ignore matches around `pos' (the point position when ;; entering this funcyion) since that's presumably what ;; we're currently trying to complete. (unless (<= (match-beginning 0) pos (match-end 0)) (push (cons (match-string-no-properties n) (match-beginning 0)) result))) (nreverse result)))))) (defun beancount-get-account-names () "Return a list of known account names available in the buffer." (when (null beancount-accounts) ;; Collecting a full list and then deduping it is a heavy ;; operation. But because of caching the will only happen once - ;; whenever a completion is requested. (setq beancount-accounts (sort (beancount-collect-unique beancount-account-regexp 0) #'string<))) beancount-accounts) (defun beancount-collect-unique (regexp n) "Return an unique list of REGEXP group N in the current buffer." (delete-dups (mapcar #'car (beancount-collect-pos-alist regexp n)))) (defun beancount-account-completion-table (string pred action) (if (eq action 'metadata) '(metadata (category . beancount-account)) (with-current-buffer (let ((win (minibuffer-selected-window))) (if (window-live-p win) (window-buffer win) (current-buffer))) (complete-with-action action (beancount-get-account-names) string pred)))) ;; Default to substring completion for beancount accounts. (defconst beancount--completion-overrides '(beancount-account (styles basic partial-completion substring))) (add-to-list 'completion-category-defaults beancount--completion-overrides) (defun beancount-number-alignment-column () "Return the column to which postings amounts should be aligned to. Returns `beancount-number-alignment-column' unless it is 0. In that case, scan the buffer to determine the minimum column that will allow to align all numbers." (if (> beancount-number-alignment-column 0) beancount-number-alignment-column (save-excursion (save-match-data (let ((account-width 0) (number-width 0)) (goto-char (point-min)) (while (re-search-forward beancount-posting-regexp nil t) (if (match-string 2) (let ((accw (- (match-end 1) (line-beginning-position))) (numw (- (match-end 3) (match-beginning 3)))) (setq account-width (max account-width accw) number-width (max number-width numw))))) (+ account-width 2 number-width)))))) (defun beancount-compute-indentation () "Return the column to which the current line should be indented." (save-excursion (beginning-of-line) (cond ;; Only timestamped directives start with a digit. ((looking-at-p "[0-9]") 0) ;; Otherwise look at the previous line. ((and (= (forward-line -1) 0) (or (looking-at-p "[ \t].+") (looking-at-p beancount-timestamped-directive-regexp) (looking-at-p beancount-transaction-regexp))) beancount-transaction-indent) ;; Default. (t 0)))) (defun beancount-align-number (target-column) (save-excursion (beginning-of-line) ;; Check if the current line is a posting with a number to align. (when (and (or (looking-at beancount-posting-regexp) (looking-at beancount-balance-regexp)) (match-string 2)) (let* ((account-end-column (- (match-end 1) (line-beginning-position))) (number-width (- (match-end 3) (match-beginning 3))) (account-end (match-end 1)) (number-beginning (match-beginning 3)) (spaces (max 2 (- target-column account-end-column number-width)))) (unless (eq spaces (- number-beginning account-end)) (goto-char account-end) (delete-region account-end number-beginning) (insert (make-string spaces ? ))))))) (defun beancount-indent-line () (let ((indent (beancount-compute-indentation)) (savep (> (current-column) (current-indentation)))) (unless (eq indent (current-indentation)) (if savep (save-excursion (indent-line-to indent)) (indent-line-to indent))) (beancount-align-number (beancount-number-alignment-column)))) (defun beancount-indent-region (start end) "Indent a region automagically. START and END specify the region to indent." (let ((deactivate-mark nil) (beancount-number-alignment-column (beancount-number-alignment-column))) (save-excursion (setq end (copy-marker end)) (goto-char start) (or (bolp) (forward-line 1)) (while (< (point) end) (unless (looking-at-p "\\s-*$") (beancount-indent-line)) (forward-line 1)) (move-marker end nil)))) (defun beancount-indent-transaction (&optional _justify _region) "Indent Beancount transaction at point." (interactive) (save-excursion (let ((bounds (beancount-find-transaction-extents (point)))) (beancount-indent-region (car bounds) (cadr bounds))))) (defun beancount-transaction-clear (&optional arg) "Clear transaction at point. With a prefix argument set the transaction as pending." (interactive "P") (save-excursion (save-match-data (let ((flag (if arg "!" "*"))) (beancount-goto-transaction-begin) (if (looking-at beancount-transaction-regexp) (replace-match flag t t nil 2)))))) (defun beancount-transaction-flag (arg) "Prompt for a flag and set the transaction's flag to the response, uppercased." (interactive "cFlag:") (save-excursion (save-match-data (let ((flag (upcase (char-to-string arg)))) (beancount-goto-transaction-begin) (if (looking-at beancount-transaction-regexp) (replace-match flag t t nil 2)))))) (defun beancount-insert-account (account-name) "Insert one of the valid account names in this file. Uses ido niceness according to `beancount-use-ido'." (interactive (list (if beancount-use-ido ;; `ido-completing-read' does not understand functional ;; completion tables thus directly build a list of the ;; accounts in the buffer (let ((beancount-accounts (sort (beancount-collect-unique beancount-account-regexp 0) #'string<))) (ido-completing-read "Account: " beancount-accounts nil nil (thing-at-point 'word))) (completing-read "Account: " #'beancount-account-completion-table nil t (thing-at-point 'word))))) (let ((bounds (bounds-of-thing-at-point 'word))) (when bounds (delete-region (car bounds) (cdr bounds)))) (insert account-name)) (defmacro beancount-for-line-in-region (begin end &rest exprs) "Iterate over each line in region until an empty line is encountered." `(save-excursion (let ((end-marker (copy-marker ,end))) (goto-char ,begin) (beginning-of-line) (while (and (not (eobp)) (< (point) end-marker)) (beginning-of-line) (progn ,@exprs) (forward-line 1) )))) (defun beancount-align-numbers (begin end &optional requested-currency-column) "Align all numbers in the given region. CURRENCY-COLUMN is the character at which to align the beginning of the amount's currency. If not specified, use the smallest columns that will align all the numbers. With a prefix argument, align with the fill-column." (interactive "r") ;; With a prefix argument, align with the fill-column. (when current-prefix-arg (setq requested-currency-column fill-column)) ;; Loop once in the region to find the length of the longest string before the ;; number. (let (prefix-widths number-widths (number-padding " ")) (beancount-for-line-in-region begin end (let ((line (thing-at-point 'line))) (when (string-match (concat "\\(.*?\\)" "[ \t]+" "\\(" beancount-number-regexp "\\)" "[ \t]+" beancount-currency-regexp) line) (push (string-width (match-string 1 line)) prefix-widths) (push (string-width (match-string 2 line)) number-widths) ))) (when prefix-widths ;; Loop again to make the adjustments to the numbers. (let* ((number-width (apply 'max number-widths)) (number-format (format "%%%ss" number-width)) ;; Compute rightmost column of prefix. (max-prefix-width (apply 'max prefix-widths)) (max-prefix-width (if requested-currency-column (max (- requested-currency-column (string-width number-padding) number-width 1) max-prefix-width) max-prefix-width)) (prefix-format (format "%%-%ss" max-prefix-width)) ) (beancount-for-line-in-region begin end (let ((line (thing-at-point 'line))) (when (string-match (concat "^\\([^\"]*?\\)" "[ \t]+" "\\(" beancount-number-regexp "\\)" "[ \t]+" "\\(.*\\)$") line) (delete-region (line-beginning-position) (line-end-position)) (let* ((prefix (match-string 1 line)) (number (match-string 2 line)) (rest (match-string 3 line)) ) (insert (format prefix-format prefix)) (insert number-padding) (insert (format number-format number)) (insert " ") (insert rest))))))))) (defun beancount-align-to-previous-number () "Align postings under the point's paragraph. This function looks for a posting in the previous transaction to determine the column at which to align the transaction, or otherwise the fill column, and align all the postings of this transaction to this column." (interactive) (let* ((begin (save-excursion (beancount-beginning-of-directive) (point))) (end (save-excursion (goto-char begin) (forward-paragraph 1) (point))) (currency-column (or (beancount-find-previous-alignment-column) fill-column))) (beancount-align-numbers begin end currency-column))) (defun beancount-beginning-of-directive () "Move point to the beginning of the enclosed or preceding directive." (beginning-of-line) (while (and (> (point) (point-min)) (not (looking-at "[0-9][0-9][0-9][0-9][\-/][0-9][0-9][\-/][0-9][0-9]"))) (forward-line -1))) (defun beancount-find-previous-alignment-column () "Find the preceding column to align amounts with. This is used to align transactions at the same column as that of the previous transaction in the file. This function merely finds what that column is and returns it (an integer)." ;; Go hunting for the last column with a suitable posting. (let (column) (save-excursion ;; Go to the beginning of the enclosing directive. (beancount-beginning-of-directive) (forward-line -1) ;; Find the last posting with an amount and a currency on it. (let ((posting-regexp (concat "\\s-+" beancount-account-regexp "\\s-+" beancount-number-regexp "\\s-+" "\\(" beancount-currency-regexp "\\)")) (balance-regexp (concat beancount-date-regexp "\\s-+" "balance" "\\s-+" beancount-account-regexp "\\s-+" beancount-number-regexp "\\s-+" "\\(" beancount-currency-regexp "\\)"))) (while (and (> (point) (point-min)) (not (or (looking-at posting-regexp) (looking-at balance-regexp)))) (forward-line -1)) (when (or (looking-at posting-regexp) (looking-at balance-regexp)) (setq column (- (match-beginning 1) (point)))) )) column)) (defun beancount--account-currency (account) ;; Build a regexp that matches an open directive that specifies a ;; single account currencydaaee. The currency is match group 1. (let ((re (concat "^" beancount-date-regexp " +open" "\\s-+" (regexp-quote account) "\\s-+\\(" beancount-currency-regexp "\\)\\s-+"))) (save-excursion (goto-char (point-min)) (when (re-search-forward re nil t) ;; The account has declared a single currency, so we can fill it in. (match-string-no-properties 1))))) (defun beancount--electric-currency () (when (and beancount-electric-currency (eq last-command-event ?\n)) (save-excursion (forward-line -1) (when (and (beancount-inside-transaction-p) (looking-at (concat "\\s-+\\(" beancount-account-regexp "\\)" "\\s-+\\(" beancount-number-regexp "\\)\\s-*$"))) ;; Last line is a posting without currency. (let* ((account (match-string 1)) (pos (match-end 0)) (currency (beancount--account-currency account))) (when currency (save-excursion (goto-char pos) (insert " " currency)))))))) (defmacro beancount--encode-time (time) "Compatibility helper. Impedence match the `encode-time' interface between Emacs-26 and later Emacs releases. It can be eliminated once support for Emacs-26 is dropped." (if (version< emacs-version "27.1") `(apply #'encode-time ,time) `(encode-time ,time))) (defun beancount--parse-date (string) "Parse the STRING date in the format %Y-%m-%d into a Lisp timestamp." (save-match-data (string-match "\\`\\([0-9][0-9][0-9][0-9]\\)-\\([0-9][0-9]\\)-\\([0-9][0-9]\\)\\'" string) (beancount--encode-time (list 0 0 0 (string-to-number (match-string 3 string)) (string-to-number (match-string 2 string)) (string-to-number (match-string 1 string)) nil -1 nil)))) (defun beancount--format-date (time) "Format the Lisp timestamp TIME into a date in the format %Y-%m-%d." (format-time-string "%Y-%m-%d" time)) (defun beancount-insert-date (&optional days) "Start a new timestamped directive with date DAYS before today." (interactive "P") (unless (bolp) (newline)) (insert (beancount--format-date (time-add (current-time) (days-to-time (- (or days 0))))))) (defun beancount--shift-date-at-point (days) "Shift the date under point by a specified number of DAYS." (if (thing-at-point-looking-at beancount-date-regexp 10) (let ((pos (point)) (date (beancount--parse-date (match-string 0)))) (replace-match (beancount--format-date (time-add date (days-to-time days))) t t) ;; Ensure that point stays in the same position. (goto-char pos)) (user-error "No date at point"))) (defun beancount-date-up-day (&optional days) "Increase the date in the current line by one day. With prefix ARG, change that many days." (interactive "p") (beancount--shift-date-at-point (or days 1))) (defun beancount-date-down-day (&optional days) "Decrease the date in the current line by one day. With prefix ARG, change that many days." (interactive "p") (beancount--shift-date-at-point (- (or days 1)))) (defun beancount--get-date-component-at-point () "Determine which component of the date (year, month, day) the cursor is on. Returns `'year', `'month', `'day', or nil if not on a date." (when (thing-at-point-looking-at beancount-date-regexp 10) (let* ((date-start (match-beginning 0)) (date-end (match-end 0)) (pos (point)) (date-string (match-string 0))) (cond ;; Year: positions 0-3 ((and (>= pos date-start) (< pos (+ date-start 4))) 'year) ;; Separator after year: position 4 ((= pos (+ date-start 4)) 'year) ;; Month: positions 5-6 ((and (>= pos (+ date-start 5)) (< pos (+ date-start 7))) 'month) ;; Separator after month: position 7 ((= pos (+ date-start 7)) 'month) ;; Day: positions 8-9 ((and (>= pos (+ date-start 8)) (<= pos date-end)) 'day) (t nil))))) (defun beancount--shift-date-component-at-point (increment) "Shift the date component at point by INCREMENT units. The component (year, month, or day) is determined by cursor position." (if (thing-at-point-looking-at beancount-date-regexp 10) (let* ((pos (point)) (component (beancount--get-date-component-at-point)) (date-string (match-string 0)) (date (beancount--parse-date date-string)) (decoded (decode-time date)) (second (nth 0 decoded)) (minute (nth 1 decoded)) (hour (nth 2 decoded)) (day (nth 3 decoded)) (month (nth 4 decoded)) (year (nth 5 decoded)) new-date) (pcase component ('year (setq new-date (beancount--encode-time (list second minute hour day month (+ year increment) nil -1 nil)))) ('month (let* ((new-month (+ month increment)) (new-year year) (month-offset (if (> new-month 0) (/ (1- new-month) 12) (/ (- new-month 12) 12)))) (setq new-year (+ year month-offset)) (setq new-month (- new-month (* month-offset 12))) ;; Handle day overflow (e.g., Jan 31 -> Feb 31 should become Feb 28/29) (let ((max-day (calendar-last-day-of-month new-month new-year))) (when (> day max-day) (setq day max-day))) (setq new-date (beancount--encode-time (list second minute hour day new-month new-year nil -1 nil))))) ('day (setq new-date (beancount--encode-time (list second minute hour (+ day increment) month year nil -1 nil)))) (_ (user-error "Could not determine date component at point"))) (replace-match (beancount--format-date new-date) t t) (goto-char pos)) (user-error "No date at point"))) (defun beancount-date-up (&optional n) "Increase the date component at point by N units (default 1). If cursor is on year, increment year; on month, increment month; on day, increment day." (interactive "p") (beancount--shift-date-component-at-point (or n 1))) (defun beancount-date-down (&optional n) "Decrease the date component at point by N units (default 1). If cursor is on year, decrement year; on month, decrement month; on day, decrement day." (interactive "p") (beancount--shift-date-component-at-point (- (or n 1)))) (defvar beancount-install-dir nil "Directory in which Beancount's source is located. Only useful if you have not installed Beancount properly in your PATH.") (defvar beancount-check-program "bean-check" "Program to run to run just the parser and validator on an input file.") (defvar compilation-read-command) (defun beancount--run (prog &rest args) (let ((process-environment (if beancount-install-dir `(,(concat "PYTHONPATH=" beancount-install-dir) ,(concat "PATH=" (expand-file-name "bin" beancount-install-dir) ":" (getenv "PATH")) ,@process-environment) process-environment)) (compile-command (mapconcat (lambda (arg) (if (stringp arg) (shell-quote-argument arg) "")) (cons prog args) " "))) (call-interactively 'compile))) (defun beancount-check () "Run `beancount-check-program'." (interactive) (let ((compilation-read-command nil)) (beancount--run beancount-check-program (file-relative-name buffer-file-name)))) (defvar beancount-query-program "bean-query" "Program to run to run just the parser and validator on an input file.") (defun beancount-query () "Run bean-query." (interactive) ;; Don't let-bind compilation-read-command this time, since the default ;; command is incomplete. (beancount--run beancount-query-program (file-relative-name buffer-file-name) t)) (defvar beancount-doctor-program "bean-doctor" "Program to run the doctor commands.") (defun beancount-context () "Get the \"context\" from `beancount-doctor-program'." (interactive) (let ((compilation-read-command nil)) (beancount--run beancount-doctor-program "context" (file-relative-name buffer-file-name) (number-to-string (line-number-at-pos))))) ;; There is no length limit for links but it seems reasonable to ;; limit the search for the link to the 128 characters before and ;; after the point. This number is chosen arbitrarily. (defun beancount--bounds-of-account-at-point () (when (thing-at-point-looking-at beancount-account-regexp 128) (cons (match-beginning 0) (match-end 0)))) (put 'beancount-account 'bounds-of-thing-at-point #'beancount--bounds-of-account-at-point) (defun beancount--bounds-of-link-at-point () (when (thing-at-point-looking-at (concat "\\^[" beancount-tag-chars "]+") 128) (cons (match-beginning 0) (match-end 0)))) (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-target-at-point () "Get link, tag or line at point, or nil." (let ((lnarg (if mark-active (format "%d:%d" (line-number-at-pos (region-beginning)) (line-number-at-pos (region-end))) (format "%d" (line-number-at-pos))))) (let* ((link-word (thing-at-point 'beancount-link)) (link (when (and link-word (string-match "\\^" link-word)) link-word)) (tag-word (thing-at-point 'beancount-tag)) (tag (when (and tag-word (string-match "\\#" tag-word)) tag-word))) (or link tag lnarg)))) (defun beancount-linked () "Get the \"linked\" info from `beancount-doctor-program', either linked or tags transactions at point." (interactive) (let ((compilation-read-command nil) (target (beancount-linked--get-target-at-point))) (beancount--run beancount-doctor-program "linked" buffer-file-name target))) ;; Note: Eventually we'd like to be able to honor some metadata in the file that ;; would point to the top-level filename. (defun beancount-command-on-region (rmin rmax command) "Run a command with a region as the final arguments." (when (use-region-p) (let* ((compilation-read-command nil) (args (append command (list buffer-file-name (format "%d:%d" (line-number-at-pos rmin) (line-number-at-pos (if (= 0 (save-excursion (goto-char rmax) (current-column))) (1- rmax) rmax))) )))) (apply #'beancount--run args)))) (defun beancount-region-default (rmin rmax) (interactive "r") (beancount-command-on-region rmin rmax (list beancount-doctor-program "region"))) (defun beancount-region-value (rmin rmax) (interactive "r") (beancount-command-on-region rmin rmax (list beancount-doctor-program "region" "--conversion=value"))) (defun beancount-region-cost (rmin rmax) (interactive "r") (beancount-command-on-region rmin rmax (list beancount-doctor-program "region" "--conversion=cost"))) (defvar beancount-price-program "bean-price" "Program to run the price fetching commands.") (defun beancount-insert-prices () "Run bean-price on the current file and insert the output inline." (interactive) (call-process beancount-price-program nil t nil (file-relative-name buffer-file-name))) ;;; Transaction highlight. (defvar beancount-highlight-overlay (list)) (make-variable-buffer-local 'beancount-highlight-overlay) (defun beancount-highlight-overlay-make () (let ((overlay (make-overlay 1 1))) (overlay-put overlay 'face 'beancount-highlight) (overlay-put overlay 'priority '(nil . 99)) overlay)) (defun beancount-highlight-transaction-at-point () "Move the highlight overlay to the current transaction." (when beancount-highlight-transaction-at-point (unless beancount-highlight-overlay (setq beancount-highlight-overlay (beancount-highlight-overlay-make))) (let* ((bounds (beancount-find-transaction-extents (point))) (begin (car bounds)) (end (cadr bounds))) (if (> (- end begin) 0) (move-overlay beancount-highlight-overlay begin end) (move-overlay beancount-highlight-overlay 1 1))))) ;;; Outline minor mode support. (defun beancount-outline-cycle (&optional arg) "Implement visibility cycling a la `org-mode'. The behavior of this command is determined by the first matching condition among the following: 1. When point is at the beginning of the buffer, or when called with a `\\[universal-argument]' universal argument, rotate the entire buffer through 3 states: - OVERVIEW: Show only top-level headlines. - CONTENTS: Show all headlines of all levels, but no body text. - SHOW ALL: Show everything. 2. When point is at the beginning of a headline, rotate the subtree starting at this line through 3 different states: - FOLDED: Only the main headline is shown. - CHILDREN: The main headline and its direct children are shown. From this state, you can move to one of the children and zoom in further. - SUBTREE: Show the entire subtree, including body text." (interactive "P") (setq deactivate-mark t) (cond ;; Beginning of buffer or called with C-u: Global cycling ((or (equal arg '(4)) (and (bobp) ;; org-mode style behaviour - only cycle if not on a heading (not (outline-on-heading-p)))) (beancount-cycle-buffer)) ;; At a heading: rotate between three different views ((save-excursion (beginning-of-line 1) (looking-at outline-regexp)) (outline-back-to-heading) (let ((goal-column 0) eoh eol eos) ;; First, some boundaries (save-excursion (save-excursion (beancount-next-line) (setq eol (point))) (outline-end-of-heading) (setq eoh (point)) (outline-end-of-subtree) (setq eos (point))) ;; Find out what to do next and set `this-command' (cond ((= eos eoh) ;; Nothing is hidden behind this heading (beancount-message "EMPTY ENTRY")) ((>= eol eos) ;; Entire subtree is hidden in one line: open it (outline-show-entry) (outline-show-children) (beancount-message "CHILDREN") (setq this-command 'beancount-cycle-children)) ((eq last-command 'beancount-cycle-children) ;; We just showed the children, now show everything. (outline-show-subtree) (beancount-message "SUBTREE")) (t ;; Default action: hide the subtree. (outline-hide-subtree) (beancount-message "FOLDED"))))))) (defvar beancount-current-buffer-visibility-state nil "Current visibility state of buffer.") (make-variable-buffer-local 'beancount-current-buffer-visibility-state) (defvar beancount-current-buffer-visibility-state) (defun beancount-cycle-buffer (&optional arg) "Rotate the visibility state of the buffer through 3 states: - OVERVIEW: Show only top-level headlines. - CONTENTS: Show all headlines of all levels, but no body text. - SHOW ALL: Show everything. With a numeric prefix ARG, show all headlines up to that level." (interactive "P") (save-excursion (cond ((integerp arg) (outline-show-all) (outline-hide-sublevels arg)) ((eq last-command 'beancount-cycle-overview) ;; We just created the overview - now do table of contents ;; This can be slow in very large buffers, so indicate action ;; Visit all headings and show their offspring (goto-char (point-max)) (while (not (bobp)) (condition-case nil (progn (outline-previous-visible-heading 1) (outline-show-branches)) (error (goto-char (point-min))))) (beancount-message "CONTENTS") (setq this-command 'beancount-cycle-toc beancount-current-buffer-visibility-state 'contents)) ((eq last-command 'beancount-cycle-toc) ;; We just showed the table of contents - now show everything (outline-show-all) (beancount-message "SHOW ALL") (setq this-command 'beancount-cycle-showall beancount-current-buffer-visibility-state 'all)) (t ;; Default action: go to overview (let ((toplevel (cond (current-prefix-arg (prefix-numeric-value current-prefix-arg)) ((save-excursion (beginning-of-line) (looking-at outline-regexp)) (max 1 (funcall outline-level))) (t 1)))) (outline-hide-sublevels toplevel)) (beancount-message "OVERVIEW") (setq this-command 'beancount-cycle-overview beancount-current-buffer-visibility-state 'overview))))) (defun beancount-message (msg) "Display MSG, but avoid logging it in the *Messages* buffer." (let ((message-log-max nil)) (message msg))) (defun beancount-next-line () "Forward line, but mover over invisible line ends. Essentially a much simplified version of `next-line'." (interactive) (beginning-of-line 2) (while (and (not (eobp)) (get-char-property (1- (point)) 'invisible)) (beginning-of-line 2))) ;;; Fava (defvar beancount--fava-process nil) (defun beancount-fava () "Start (and open) or stop the fava server." (interactive) (when beancount--fava-process (delete-process beancount--fava-process) (setq beancount--fava-process nil) (message "Fava process killed")) (setq beancount--fava-process (start-process "fava" (get-buffer-create "*fava*") "fava" (if (eq 'beancount-mode major-mode) (buffer-file-name) (read-file-name "File to load: ")))) (set-process-filter beancount--fava-process #'beancount--fava-filter) (message "Fava process started")) (defun beancount--fava-filter (_process output) "Open fava url as soon as the address is announced." (with-current-buffer "*fava*" (insert output)) (if-let ((url (string-match "Starting 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)) 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 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)) 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 re 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-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-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 ((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