diff --git a/emacs/.config/doom/beancount.el b/emacs/.config/doom/beancount.el new file mode 100644 index 0000000..42d0806 --- /dev/null +++ b/emacs/.config/doom/beancount.el @@ -0,0 +1,1013 @@ +;;; 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 +;; 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) + +(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 postinng 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 font-lock-default-face)) + "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.") + +(defconst beancount-account-directive-names + '("balance" + "close" + "document" + "note" + "open" + "pad") + "Directive bames that can appear after a date and are followd by an account.") + +(defconst beancount-no-account-directive-names + '("commodity" + "event" + "price" + "query" + "txn") + "Directive names that can appear after a date and 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" + "allow_deprecated_none_for_tags_and_links" + "allow_pipe_separator" + "booking_method" + "conversion_currency" + "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")) + +(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:]][[: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 char that is neither a space nor a lower-case letter. + "[^ 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-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-+\\(.+\\)") + +(defvar beancount-outline-regexp "\\(;;;+\\|\\*+\\)") + +(defun beancount-outline-level () + (let ((len (- (match-end 1) (match-beginning 1)))) + (if (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 'org-level-1) + (2 'org-level-2) + (3 'org-level-3) + (4 'org-level-4) + (5 'org-level-5) + (6 'org-level-6) + (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) + ;; Number followed by currency not covered by previous rules. + (,(concat beancount-number-regexp "\\s-+" beancount-currency-regexp) . 'beancount-amount) + ;; Accounts not covered by previous rules. + (,beancount-account-regexp . 'beancount-account) + )) + +(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-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 g)]) #'beancount-transaction-clear) + (define-key map (vconcat p [(l)]) #'beancount-check) + (define-key map (vconcat p [(q)]) #'beancount-query) + (define-key map (vconcat p [(x)]) #'beancount-context) + (define-key map (vconcat p [(k)]) #'beancount-linked) + (define-key map (vconcat p [(p)]) #'beancount-insert-prices) + (define-key map (vconcat p [(\;)]) #'beancount-align-to-previous-number) + (define-key map (vconcat p [(\:)]) #'beancount-align-numbers) + 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 fundamental-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)) + +(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-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)) + + ;; 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 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 regexp 1) #'string<))) + (complete-with-action action candidates string pred)))) + (list (match-beginning 1) (match-end 1) completion-table)))))))) + +(defun beancount-collect (regexp n) + "Return an unique list of REGEXP group N in the current buffer." + (let ((pos (point))) + (save-excursion + (save-match-data + (let ((hash (make-hash-table :test 'equal))) + (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)) + (puthash (match-string-no-properties n) nil hash))) + (hash-table-keys hash)))))) + +(defun beancount-account-completion-table (string pred action) + (if (eq action 'metadata) '(metadata (category . beancount-account)) + (if (null beancount-accounts) + (setq beancount-accounts + (sort (beancount-collect beancount-account-regexp 0) #'string<))) + (complete-with-action action beancount-accounts 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 (looking-at beancount-posting-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))) + (unless (eq this-command 'beancount-tab-dwim) + (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-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 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 (length (match-string 1 line)) prefix-widths) + (push (length (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 (length 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)))))))) + +(defun beancount-insert-date () + "Start a new timestamped directive." + (interactive) + (unless (bolp) (newline)) + (insert (format-time-string "%Y-%m-%d") " ")) + +(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))))) + + +(defun beancount-linked () + "Get the \"linked\" info from `beancount-doctor-program'." + (interactive) + (let ((compilation-read-command nil)) + (beancount--run beancount-doctor-program "linked" + (file-relative-name buffer-file-name) + (number-to-string (line-number-at-pos))))) + +(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 highligh + +(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))) + +(provide 'beancount) +;;; beancount.el ends here