;;; lang/beancount/autoload.el -*- lexical-binding: t; -*-
;;
;;; Helpers
;; Lifted from ledger-mode
(defconst +beancount--payee-any-status-regex
"^[0-9]+[-/][-/.=0-9]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.+?\\)\\s-*\\(;\\|$\\)")
(defun +beancount--sort-startkey ()
"Return the actual date so the sort subroutine doesn't sort on the entire first line."
(buffer-substring-no-properties (point) (+ 10 (point))))
(defun +beancount--navigate-next-xact ()
"Move point to beginning of next xact."
;; make sure we actually move to the next xact, even if we are the beginning
;; of one now.
(if (looking-at +beancount--payee-any-status-regex)
(forward-line))
(if (re-search-forward +beancount--payee-any-status-regex nil t)
(goto-char (match-beginning 0))
(goto-char (point-max))))
(defun +beancount--navigate-start-xact-or-directive-p ()
"Return t if at the beginning of an empty or all-whitespace line."
(not (looking-at "[ \t]\\|\\(^$\\)")))
(defun +beancount--navigate-next-xact-or-directive ()
"Move to the beginning of the next xact or directive."
(interactive)
(beginning-of-line)
(if (+beancount--navigate-start-xact-or-directive-p) ; if we are the start of an xact, move forward to the next xact
(progn
(forward-line)
(if (not (+beancount--navigate-start-xact-or-directive-p)) ; we have moved forward and are not at another xact, recurse forward
(+beancount--navigate-next-xact-or-directive)))
(while (not (or (eobp) ; we didn't start off at the beginning of an xact
(+beancount--navigate-start-xact-or-directive-p)))
(forward-line))))
(defun +beancount--navigate-next-xact ()
"Move point to beginning of next xact."
;; make sure we actually move to the next xact, even if we are the
;; beginning of one now.
(if (looking-at +beancount--payee-any-status-regex)
(forward-line))
(if (re-search-forward +beancount--payee-any-status-regex nil t)
(goto-char (match-beginning 0))
(goto-char (point-max))))
(defun +beancount--navigate-beginning-of-xact ()
"Move point to the beginning of the current xact."
;; need to start at the beginning of a line in case we are in the first line of an xact already.
(beginning-of-line)
(let ((sreg (concat "^[=~[:digit:]]")))
(unless (looking-at sreg)
(re-search-backward sreg nil t)
(beginning-of-line)))
(point))
(defun +beancount--navigate-end-of-xact ()
"Move point to end of xact."
(+beancount--navigate-next-xact-or-directive)
(re-search-backward ".$")
(end-of-line)
(point))
;;
;;; Commands
;;;###autoload
(defun +beancount/sort-buffer (&optional reverse)
"Sort all transactions in the buffer.
If REVERSE (the prefix arg) is non-nil, sort them in reverse."
(interactive "P")
(+beancount/sort-region (point-min) (point-max) reverse))
;;;###autoload
(defun +beancount/sort-region (beg end &optional reverse)
"Sort the transactions inside BEG and END.
If REVERSE (the prefix arg) is non-nil, sort the transactions in reverst order."
(interactive
(list (region-beginning)
(region-end)
(and current-prefix-arg t)))
(let* ((new-beg beg)
(new-end end)
(bounds (save-excursion
(list (+beancount--navigate-beginning-of-xact)
(+beancount--navigate-end-of-xact))))
(point-delta (- (point) (car bounds)))
(target-xact (buffer-substring (car bounds) (cadr bounds)))
(inhibit-modification-hooks t))
(save-excursion
(save-restriction
(goto-char beg)
;; make sure beg of region is at the beginning of a line
(beginning-of-line)
;; make sure point is at the beginning of a xact
(unless (looking-at +beancount--payee-any-status-regex)
(+beancount--navigate-next-xact))
(setq new-beg (point))
(goto-char end)
(+beancount--navigate-next-xact)
;; make sure end of region is at the beginning of next record after the
;; region
(setq new-end (point))
(narrow-to-region new-beg new-end)
(goto-char new-beg)
(let ((inhibit-field-text-motion t))
(sort-subr
reverse
#'+beancount--navigate-next-xact
#'+beancount--navigate-end-of-xact
#'+beancount--sort-startkey))))
(goto-char (point-min))
(re-search-forward (regexp-quote target-xact))
(goto-char (+ (match-beginning 0) point-delta))))
(defvar compilation-read-command)
;;;###autoload
(defun +beancount/balance (&optional all-accounts)
"Display a balance report with bean-report (bean-report bal)."
(interactive "P")
(let ((args (unless all-accounts '("-e" "Assets|Liabilities")))
compilation-read-command
current-prefix-arg)
(apply #'beancount--run "bean-report" buffer-file-name "balances" args)))
;;;###autoload
(defun +beancount/clone-transaction ()
"Clones a transaction from (and to the bottom of) the current ledger buffer.
Updates the date to today."
(interactive)
(save-restriction
(widen)
(when-let (transaction
(completing-read
"Clone transaction: "
(string-lines (buffer-string))
(doom-partial #'string-match-p "^[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [*!] ")
t))
(goto-char (point-min))
(re-search-forward (concat "^" (regexp-quote transaction)))
(+beancount/clone-this-transaction t))))
;;;###autoload
(defun +beancount/clone-this-transaction (&optional arg)
"Clones the transaction at point to the bottom of the ledger.
Updates the date to today."
(interactive "P")
(if (and (not arg) (looking-at-p "^$"))
(call-interactively #'+beancount/clone-transaction)
(save-restriction
(widen)
(let ((transaction
(buffer-substring-no-properties
(save-excursion
(beancount-goto-transaction-begin)
(re-search-forward " " nil t)
(point))
(save-excursion
(beancount-goto-transaction-end)
(point)))))
(goto-char (point-max))
(delete-blank-lines)
(beancount-insert-date)
(insert transaction)))))
;;;###autoload
(defun +beancount/occur (account &optional disable?)
"Hide transactions that don't involve ACCOUNT.
If DISABLE? (universal arg), reveal hidden accounts without prompting."
(interactive
(list (unless current-prefix-arg
;; REVIEW: Could/should this be generalized to search for arbitrary
;; regexps, if desired?
(completing-read "Account: " #'beancount-account-completion-table))
current-prefix-arg))
(with-silent-modifications
(save-excursion
(setq header-line-format nil)
;; TODO: Namespace these text-properties, in case of conflicts
(remove-text-properties (point-min) (point-max) '(invisible nil display nil))
(unless disable?
;; TODO: Prettier header-line display
(setq header-line-format `("" "Filtering by account: " ,account))
(let ((start (point-min))
(placeholder (propertize "[...]\n" 'face 'shadow)))
(goto-char start)
(while (re-search-forward (concat "\\_<" (regexp-quote account) "\\_>") nil t)
(save-excursion
(seq-let (beg end) (beancount-find-transaction-extents (point))
;; TODO: Highlight entry (ala org-occur)
(if (= beg end)
(setq end (save-excursion (goto-char end) (1+ (eol)))))
(put-text-property start beg 'invisible t)
(put-text-property start beg 'display placeholder)
(setq start end))))
(put-text-property start (point-max) 'invisible t)
(put-text-property start (point-max) 'display placeholder))))))
;;;###autoload
(defun +beancount/next-transaction (&optional count)
"Jump to the start of the next COUNT-th transaction."
(interactive "p")
(let ((beancount-transaction-regexp
;; Don't skip over timestamped directives (like balance or event
;; declarations).
(concat beancount-timestamped-directive-regexp
"\\|" beancount-transaction-regexp)))
(dotimes (_ (or count 1))
(beancount-goto-next-transaction))))
;;;###autoload
(defun +beancount/previous-transaction (&optional count)
"Jump to the start of current or previous COUNT-th transaction.
Return non-nil if successful."
(interactive "p")
(let ((pos (point)))
(condition-case e
(progn
;; Ensures "jump to top of current transaction" behavior that is
;; common for jump-to-previous commands like this in other Emacs modes
;; (like org-mode).
(or (bolp) (goto-char (eol)))
(re-search-backward
(concat beancount-timestamped-directive-regexp
"\\|" beancount-transaction-regexp)))
('search-failed (goto-char pos) nil))))