doomemacs/modules/lang/beancount/autoload.el

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