dotfiles/emacs/.config/doom/beancount.el

;;; beancount.el --- A major mode to edit Beancount input files. -*- lexical-binding: t -*-

;; Copyright (C) 2013 Martin Blais <blais@furius.ca>
;; Copyright (C) 2015 Free Software Foundation, Inc.
;; Copyright (C) 2019 Daniele Nicolodi <daniele@grinta.net>

;; Version: 0
;; Author: Martin Blais <blais@furius.ca>
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Author: Daniele Nicolodi <daniele@grinta.net>

;; 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 '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