diff options
Diffstat (limited to '.emacs.local.d/elisp/beancount.el')
| -rw-r--r-- | .emacs.local.d/elisp/beancount.el | 653 |
1 files changed, 653 insertions, 0 deletions
diff --git a/.emacs.local.d/elisp/beancount.el b/.emacs.local.d/elisp/beancount.el new file mode 100644 index 0000000..7ca2a02 --- /dev/null +++ b/.emacs.local.d/elisp/beancount.el @@ -0,0 +1,653 @@ +;;; beancount.el --- A minor mode that can be used to edit beancount input files. + +;; Copyright (C) 2013 Martin Blais <blais@furius.ca> +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Version: 0 +;; Author: Martin Blais <blais@furius.ca> +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> + +;; 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 <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; TODO: Add a flymake rule, using bean-check + +;;; Code: + +(autoload 'ido-completing-read "ido") +(require 'font-lock) + +(defgroup beancount () + "Editing mode for Beancount files." + :group 'beancount) + +(defconst beancount-timestamped-directive-names + '("balance" + "open" + "close" + "pad" + "document" + "note" + ;; The ones below are not followed by an account name. + "event" + "price" + "commodity" + "query" + "txn") + "Directive names that can appear after a date.") + +(defconst beancount-nontimestamped-directive-names + '("pushtag" + "poptag" + "option" + "include" + "plugin") + "Directive names that can appear after a date.") + +(defvar beancount-directive-names + (append beancount-nontimestamped-directive-names + beancount-timestamped-directive-names) + "A list of the directive names.") + +(defconst beancount-tag-chars "[:alnum:]-_/.") + +(defconst beancount-account-categories + '("Assets" "Liabilities" "Equity" "Income" "Expenses")) + +(defconst beancount-account-chars "[:alnum:]-_:") + +(defconst beancount-option-names + ;; This list is kept in sync with the options defined in + ;; beancount/parser/options.py. + ;; Note: We should eventually build a tool that spits out the current list + ;; automatically. + '("title" + "name_assets" + "name_liabilities" + "name_equity" + "name_income" + "name_expenses" + "bookin_algorithm" + "bookin_method" + "account_previous_balances" + "account_previous_earnings" + "account_previous_conversions" + "account_current_earnings" + "account_current_conversions" + "account_rounding" + "conversion_currency" + "inferred_tolerance_default" + "inferred_tolerance_multiplier" + "infer_tolerance_from_cost" + "documents" + "operating_currency" + "render_commas" + "plugin_processing_mode" + "plugin" + "long_string_maxlines" + )) + +(defvar beancount-font-lock-keywords + `(;; Reserved keywords + (,(regexp-opt beancount-directive-names) . font-lock-keyword-face) + + ;; Tags & Links + ("[#\\^][A-Za-z0-9\-_/.]+" . font-lock-type-face) + + ;; Date + ("[0-9][0-9][0-9][0-9][-/][0-9][0-9][-/][0-9][0-9]" . font-lock-constant-face) + + ;; Account + ("\\([A-Z][A-Za-z0-9\-]+:\\)+\\([A-Z][A-Za-z0-9\-]+\\)" . font-lock-builtin-face) + + ;; Txn Flags + ("! " . font-lock-warning-face) + + ;; Number + Currency + ;;; ("\\([\\-+]?[0-9,]+\\(\\.[0-9]+\\)?\\)\\s-+\\([A-Z][A-Z0-9'\.]\\{1,10\\}\\)" . ) + )) + + +(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 (vconcat p [(\')]) #'beancount-insert-account) + (define-key map (vconcat p [(control g)]) #'beancount-transaction-set-flag) + (define-key map (vconcat p [(r)]) #'beancount-init-accounts) + (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) + + ;; FIXME: Binding TAB breaks expected org-mode behavior to fold/unfold. We + ;; need to find a better solution. + ;;(define-key map [?\t] #'beancount-tab) + 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)) + +(defun beancount--goto-bob () (goto-char (point-min))) + +;;;###autoload +(define-minor-mode beancount-mode + "A minor mode to help editing Beancount files. +This can be used within other text modes, in particular, org-mode +is great for sectioning large files with many transactions. + +\\{beancount-mode-map}" + :init-value nil + :lighter " Beancount" + :group 'beancount + + ;; The following is mostly lifted from lisp-mode. + + (set (make-local-variable 'paragraph-ignore-fill-prefix) t) + (set (make-local-variable 'fill-paragraph-function) #'lisp-fill-paragraph) + + (set (make-local-variable 'comment-start) ";; ") + + ;; Look within the line for a ; following an even number of backslashes + ;; after either a non-backslash or the line beginning. + (set (make-local-variable 'comment-start-skip) + "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") + ;; Font lock mode uses this only when it KNOWS a comment is starting. + ;; FIXME: Why bother? + (set (make-local-variable 'font-lock-comment-start-skip) ";+ *") + ;; Default to `;;' in comment-region. + (set (make-local-variable 'comment-add) 1) + + ;; Org-mode sets both of these to `org-comment-or-uncomment-region', + ;; which doesn't know about our ";" comments. + (kill-local-variable 'comment-region-function) + (kill-local-variable 'uncomment-region-function) + + ;; No tabs by default. + (set (make-local-variable 'indent-tabs-mode) nil) + + (add-hook 'completion-at-point-functions + #'beancount-completion-at-point nil t) + (set (make-local-variable 'completion-ignore-case) t) + + ;; Customize font-lock for beancount. + ;; + (set-syntax-table beancount-mode-syntax-table) + (when (fboundp 'syntax-ppss-flush-cache) + (syntax-ppss-flush-cache (point-min)) + (set (make-local-variable 'syntax-begin-function) #'beancount--goto-bob)) + ;; Force font-lock to use the syntax-table to find strings-and-comments, + ;; regardless of what the "host major mode" decided. + (set (make-local-variable 'font-lock-keywords-only) nil) + ;; Important: you have to use 'nil for the mode here because in certain major + ;; modes (e.g. org-mode) the font-lock-keywords is a buffer-local variable. + (if beancount-mode + (font-lock-add-keywords nil beancount-font-lock-keywords) + (font-lock-remove-keywords nil beancount-font-lock-keywords)) + (if (fboundp 'font-lock-flush) + (font-lock-flush) + (with-no-warnings (font-lock-fontify-buffer))) + + (when beancount-mode + (beancount-init-accounts)) + ) + +(defvar beancount-accounts nil + "A list of the accounts available in this buffer. +This is a cache of the value computed by `beancount-get-accounts'.") +(make-variable-buffer-local 'beancount-accounts) + +(defun beancount-init-accounts () + "Initialize or reset the list of accounts." + (interactive) + (setq beancount-accounts (beancount-get-accounts)) + (message "Accounts updated.")) + +(defvar beancount-date-regexp "[0-9][0-9][0-9][0-9][-/][0-9][0-9][-/][0-9][0-9]" + "A regular expression to match dates.") + +(defvar beancount-account-regexp + (concat (regexp-opt beancount-account-categories) + "\\(?::[[:upper:]][" beancount-account-chars "]+\\)") + "A regular expression to match account names.") + +(defvar beancount-number-regexp "[-+]?[0-9,]+\\(?:\\.[0-9]*\\)?" + "A regular expression to match decimal numbers in beancount.") + +(defvar beancount-currency-regexp "[A-Z][A-Z-_'.]*" + "A regular expression to match currencies in beancount.") + +(defun beancount-tab () + "Try to use the right meaning of TAB." + (interactive) + (let ((cdata (beancount-completion-at-point))) + (if cdata + ;; There's beancount-specific completion at point. + (call-interactively #'completion-at-point) + (let* ((beancount-mode nil) + (fallback (key-binding (this-command-keys)))) + (if (commandp fallback) + (command-execute fallback)))))) + +(defun beancount-tags (prefix) + "Return list of all tags starting with PREFIX in current buffer. +Excludes tags appearing on the current line." + (unless (string-match "\\`[#^]" prefix) + (error "Unexpected prefix to search tags: %S" prefix)) + (let ((found ()) + (re (concat prefix "[" beancount-tag-chars "]*"))) + (save-excursion + (forward-line 0) + (while (re-search-backward re nil t) + (push (match-string 0) found))) + ;; Ignore tags on current line. + (save-excursion + (forward-line 1) + (while (re-search-forward re nil t) + (push (match-string 0) found))) + (delete-dups found))) + +(defconst beancount-txn-regexp + ;; For the full definition of a flag, see the rule that emits FLAG in + ;; beancount/parser/lexer.l. For this, let's assume that it's a single char + ;; that's neither a space nor a lower-case letter. This should be updated as + ;; the parser is improved. + "^[0-9-/]+ +\\(?:txn +\\)?[^ [:lower:]]\\($\\| \\)") + +(defun beancount-inside-txn-p () + ;; FIXME: The doc doesn't actually say how the legs of a transaction can be + ;; layed out. We assume that they all start with some space on the line. + (save-excursion + (forward-line 0) + (while (and (looking-at "[ \t]") (not (bobp))) + (forward-line -1)) + (looking-at beancount-txn-regexp))) + +(defun beancount-completion-at-point () + "Return the completion data relevant for the text at point." + (let ((bp (buffer-substring (line-beginning-position) (point)))) + (cond + ((string-match "\\`[a-z]*\\'" bp) + ;; A directive starting at BOL (hence non-timestamped). + (list (line-beginning-position) + (save-excursion (skip-chars-forward "a-z") (point)) + '("pushtag" "poptag"))) + + ((string-match + (concat "\\`option +\\(\"[a-z_]*\\)?\\'") + bp) + (list (- (point) + (if (match-end 1) (- (match-end 1) (match-beginning 1)) 0)) + (save-excursion (skip-chars-forward "a-z_") + (if (looking-at "\"") (forward-char 1)) + (point)) + (mapcar (lambda (s) (concat "\"" s "\"")) beancount-option-names))) + + ((string-match + (concat "\\`poptag +\\(#[" beancount-tag-chars "]*\\)?\\'") + bp) + (list (- (point) + (if (match-end 1) (- (match-end 1) (match-beginning 1)) 0)) + (save-excursion (skip-chars-forward beancount-tag-chars) (point)) + (save-excursion + (let ((opened ())) + (while (re-search-backward + (concat "^pushtag +\\(#[" beancount-tag-chars "]+\\)") + nil t) + (push (match-string 1) opened)) + opened)))) + + ((string-match "\\`[0-9-/]+ +\\([[:alpha:]]*\\'\\)" bp) + ;; A timestamped directive. + (list (- (point) (- (match-end 1) (match-beginning 1))) + (save-excursion (skip-chars-forward "[:alpha:]") (point)) + beancount-timestamped-directive-names)) + + ((and (beancount-inside-txn-p) + (string-match (concat "\\`[ \t]+\\([" + beancount-account-chars "]*\\)\\'") + bp)) + ;; Hopefully, an account name. We don't force the partially-written + ;; account name to start with a capital, so that it's possible to use + ;; substring completion and also so we can rely on completion to put the + ;; right capitalization (thanks to completion-ignore-case). + (list (- (point) (- (match-end 1) (match-beginning 1))) + (save-excursion (skip-chars-forward beancount-account-chars) + (point)) + #'beancount-account-completion-table)) + + ((string-match (concat "\\`[0-9-/]+ +\\(" + (regexp-opt beancount-timestamped-directive-names) + "\\) +\\([" beancount-account-chars "]*\\'\\)") + bp) + (list (- (point) (- (match-end 2) (match-beginning 2))) + (save-excursion (skip-chars-forward beancount-account-chars) + (point)) + (if (equal (match-string 1 bp) "open") + (append + (mapcar (lambda (c) (concat c ":")) beancount-account-categories) + beancount-accounts) + #'beancount-account-completion-table))) + + ((string-match (concat "[#^][" beancount-tag-chars "]*\\'") bp) + (list (- (point) (- (match-end 0) (match-beginning 0))) + (save-excursion (skip-chars-forward beancount-tag-chars) (point)) + (completion-table-dynamic #'beancount-tags)))))) + +(defun beancount-hash-keys (hashtable) + "Extract all the keys of the given hashtable. Return a sorted list." + (let (rlist) + (maphash (lambda (k _v) (push k rlist)) hashtable) + (sort rlist 'string<))) + +(defun beancount-get-accounts () + "Heuristically obtain a list of all the accounts used in all the postings. +We ignore patterns seen the line 'exclude-line'. If ALL is non-nil, look +for account names in postings as well (default is to look at the @defaccount +declarations only." + (let ((accounts (make-hash-table :test 'equal))) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward beancount-account-regexp nil t) + (puthash (match-string-no-properties 0) nil accounts))) + (sort (beancount-hash-keys accounts) 'string<))) + +(defcustom beancount-use-ido t + "If non-nil, use ido-style completion rather than the standard completion." + :type 'boolean) + +(defun beancount-account-completion-table (string pred action) + (if (eq action 'metadata) + '(metadata (category . beancount-account)) + (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))) +(cond + ((boundp 'completion-category-defaults) + (add-to-list 'completion-category-defaults beancount--completion-overrides)) + ((and (boundp 'completion-category-overrides) + (not (assq 'beancount-account completion-category-overrides))) + (push beancount--completion-overrides completion-category-overrides))) + +(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' is too dumb to understand functional + ;; completion tables! + (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)) + + +(defun beancount-transaction-set-flag () + (interactive) + (save-excursion + (backward-paragraph 1) + (forward-line 1) + (while (search-forward "!" (line-end-position) t) + (replace-match "*")))) + + +(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-max-accounts-width (begin end) + "Return the minimum widths of a list of account names on a list +of lines. Initial whitespace is ignored." + (let* (widths) + (beancount-for-line-in-region + begin end + (let* ((line (thing-at-point 'line))) + (when (string-match + (concat "^[ \t]*\\(" beancount-account-regexp "\\)") line) + (push (length (match-string 1 line)) widths)))) + (apply 'max widths))) + + +(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)) + +(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))) + + +(provide 'beancount) +;;; beancount.el ends here |