config_emacs/user-global/elisp/beancount.el

;;; package --- Summary
;;; Commentary:
;;  A humble try to port leder-mode to beancount

;;; Code:
;(require 'beancount-regex)

(require 'font-lock)
(require 'company)   ; for company-mode
(require 'pcomplete)
(require 'cl-lib)

(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-account-categories
  '("Assets"
    "Liabilities"
    "Equity"
    "Income"
    "Expenses"
    ; TODO: Fill changed root accounts automatically
    "Aktiva"
    "Verbindlichkeiten"
    "Eigenkapital"
    "Ertraege"
    "Aufwendungen"))

(defconst beancount-nontimestamped-directive-names
  '("pushtag"
    "poptag"
    "option"
    "include"
    "plugin")
  "Directive names that can appear after a date.")

(defconst beancount-option-names
  ;; this list has to be kept in sync with the options definied in
  ;; beancount/parser/options.py
  '("title"
    "name_assets"
    "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"
    ))

(defconst beancount-directive-names
  (append beancount-nontimestamped-directive-names
          beancount-timestamped-directive-names)
  "A list of directive names.")

(defconst beancount-tag-chars
  "[:alnum:]-_/."
  "Allowed tag characters.")

(defconst beancount-account-chars
  "[:alnum:]-_:"
  "Allowed account characters.")

(defconst beancount-account-regexp
  (concat (regexp-opt beancount-account-categories)
          "\\(?::[[:upper:]][" beancount-account-chars "]+\\)")
  "A regular expression to match account names.")

; TODO: currently shows all texts between ""
(defconst beancount-payee-regexp
  "\"\\(.*?\\)\"")

(defconst beancount-date-regexp
  "^[12][901][0-9]\\{2\\}-\\(\\(0[1-9]\\)\\|\\(1[012]\\)\\)-\\(\\([012][0-9]\\)\\|\\(3[01]\\)\\)"
  "Regular expression for dates.")

(defconst beancount-number-regexp
  "[-+]?[0-9,]+\\(?:\\.[0-9]*\\)"
  "Regular expression to match decimal numbers.")

(defconst beancount-tag-regexp
  (concat "#"
          "["
          beancount-tag-chars
          "]+")
  "Regular expression for valid tags.")

(defconst beancount-currency-regexp
  "[A-Z][A-Z-_'.]*"
  "Regular expression to match currencies.")


(defconst beancount-timestamped-accounts-regexp
  (concat beancount-date-regexp
          " " ;"\\(\\s-+\\)"
          (regexp-opt beancount-timestamped-directive-names)
          " ") ;"\\(\\s-+\\)")
  "A regular expression to match valid preceding characters before an account name.")

(defconst beancount-amount-and-currency-regex
  "\s-*[-]?[0-9,]+[.][0-9]\\{2\\}\s[A-Za-z0-9.]+"
  "A regular expression for amounts including currency.")

(defconst beancount-payee-any-status-regex
  "^[0-9]+[-/][-/.=0-9]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.+?\\)\\s-*\\(;\\|$\\)")

(defconst beancount-date-and-status-regex
  (concat beancount-date-regexp
          "\\(\\s-+[\\*!]\\)")
  "Returns true for YYYY-MM-DD ! and YYYY-MM-DD *.")

(defconst beancount-valid-prefix-for-directives-regex
  (concat "^"
          beancount-date-regexp
          "[ ]+"
          "[a-z]*$"))

(defconst beancount-valid-prefix-for-payee-completion-regex
  (concat "\\("
          beancount-date-and-status-regex
          " \""             ; empty space and open quotes
          "[^\"\n]*"        ; any number of chars except quotes and newline
          "\\("             ; start of optional second quoted term
          "\"[ ]+\""        ; closing quotes, whitespaces, opening quotes
          "[^\"\n]*"        ; any number of chars except quotes and newline
          "\\)?"            ; end of optional second quoted term
          "\\)$"            ; the whole regex looks from the right side of the line
          ))

(defconst beancount-valid-prefix-for-tag-completion-regex
  (concat ;"\\("
          beancount-date-and-status-regex
          " \""             ; empty space and open quotes
          "[^\"\n]*"        ; any number of chars except quotes and newline
          "\\("             ; start of optional second quoted term
          "\"[ ]+\""        ; closing quotes, whitespaces, opening quotes
          "[^\"\n]*"        ; any number of chars except quotes and newline
          "\\)?"            ; end of optional second quoted term
          "\"[ ]+#"

          ;"\\)$"            ; the whole regex looks from the right side of the line
          ))

(defconst beancount-comments-regex
  (concat ";[^\"\n]*$"))  ; right part of the line after a comment symbol if no quote or newline is included

(defconst beancount-empty-line-regex
  "^\\(\\s-+\\)" ;; maybe "^[ \t]+" is better
  "Returns true for preceding whitespaces.")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Faces
(defgroup beancount-faces nil "Beancount mode highlighting" :group 'beancount)

(defface beancount-font-default-face
  `((t :inherit default))
  "Default face"
  :group 'beancount-faces)

(defface beancount-font-xact-cleared-face
  `((t :foreground "#AAAAAA" :weight normal))
  "Default face for cleared transactions"
  :group 'beancount-faces)

(defface beancount-font-xact-pending-face
  `((t :foreground "#dc322f" :weight bold))
  "Default face for pending transactions"
  :group 'beancount-faces)

(defface beancount-font-payee-cleared-face
  `((t :inherit beancount-font-other-face))
  "Default face for pending transactions"
  :group 'beancount-faces)

(defface beancount-font-payee-pending-face
  `((t :foreground "#f24b61" :weight normal))
  "Default face for pending (!) transactions"
  :group 'beancount-faces)

(defface beancount-font-other-face
  `((t :foreground "#657b83" :weight normal))
  "Default face for other transactions"
  :group 'beancount-faces)

(defface beancount-font-posting-date-face
  `((t :foreground "#cb4b16" :weight normal))
  "Default face for dates"
  :group 'beancount-faces)

(defface beancount-font-amount-face
  `((t :foreground "#cb4b16" :weight normal))
  "Default face for amounts"
  :group 'beancount-faces)


(defvar beancount-font-lock-directives
  `(;; reserved keywords
    (,(regexp-opt beancount-directive-names) . font-lock-keyword-face)
    ;; tags & links
    ("[#\\^][A-Za-z0-9\-_/.]+" . font-lock-type-face)
    ;; comments
    (,beancount-comments-regex (0 font-lock-comment-face))
    ;; date
    (,beancount-date-regexp . 'beancount-font-posting-date-face)
    ;; account
    (,beancount-account-regexp . 'beancount-font-other-face)
    ;; payees
    ("\"\\(.*?\\)\"" . font-lock-comment-face)
    ;; txn flags
    ("! " . font-lock-warning-face)
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Alignments

(defmacro beancount-for-line-in-region (begin end &rest exprs)
  "Iterate over each line in region from BEGIN to END (EXPRS)
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)
  "Align all numbers in the current buffer from BEGIN to END."
  (interactive "r")

  ;; loop once in the buffer 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 the rightmost column of prefix
             (max-prefix-width (apply 'max prefix-widths))
             (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-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<)))

(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-in-buffer)) ;-new
  (pcomplete-uniqify-list (nreverse beancount-accounts))
;;  (setq beancount-accounts (beancount-get-accounts))
  (message "Accounts updated."))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Navigation

(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-prev-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 at the start of an xact, move backward to the previous xact
      (progn
        (forward-line -1)
        (if (not (beancount-navigate-start-xact-or-directive-p)) ; we have moved backward and are not at another xact, recurse backward
            (beancount-navigate-prev-xact-or-directive)))
    (while (not (or (bobp)
                    (beancount-navigate-start-xact-or-directive-p)))
      (forward-line -1))))

(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 at 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 stsrt off at the beginning of an xact
                    (beancount-navigate-start-xact-or-directive-p)))
      (forward-line))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Completion

(defun beancount-thing-at-point ()
  "Describe thing at points. Return 'transaction, 'posting, or nil.
Leave point at the beginning of the thing under point.")

(defun beancount-trim-trailing-whitespace (str)
  "Replace trailing whitespaces in STR."
  (replace-regexp-in-string "[ \t]*$" "" str))

;; (defun beancount-fully-complete-xact ()
;;   "Completes a transaction if there is another matching payee in the buffer."
;;   (interactive)
;;   (let* ((name (beancount-trim-trailing-whitespace (caar (beancount-parse-arguments))))
;;          xacf)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Functions for external programs

(defvar beancount-filename-main buffer-file-name
  "File name of the main beancount file for beancount-check.")

(defvar beancount-terminal-name "alacritty"
  "Name of the terminal emulator to run fava.")

(defvar beancount-fava-exec "/usr/bin/fava"
  "Full path of fava executable.")

(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")

(defun beancount--run (prog &rest args)
  "Random text PROG 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)))

(defvar beancount-check-program "bean-check"
  "Program to run the parser and validator on an input file.")

(defun beancount-check ()
  "Run `beancount-check-program'."
  (interactive)
  (let ((compilation-read-command nil))
    (beancount--run beancount-check-program beancount-filename-main)))
;                    (file-relative-name buffer-file-name))))

(defun beancount-fava ()
  "Run `beancount-fava' and open the URL in the default browser."
  (interactive)
 (start-process "termx" nil beancount-terminal-name "-e " beancount-fava-exec beancount-filename-main)
  (sleep-for 0.5) ; necessary to prevent an error
  (browse-url "127.0.0.1:5000"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Completions

(defun beancount-get-accounts-in-buffer ()
  "Return a list of all accounts."
  (let ((origin (point))
        accounts-list)
    (save-excursion
      (goto-char (point-min))
      (while (re-search-forward
              beancount-account-regexp nil t)
        (setq accounts-list (cons (match-string-no-properties 0)
                                  accounts-list))))
    (pcomplete-uniqify-list (nreverse accounts-list))))

(defun beancount-get-payees-in-buffer ()
  "Return a list of all payees."
  (let ((origin (point))
        payees-list)
    (save-excursion
      (goto-char (point-min))
      (while (re-search-forward
              "^[0-9- *]*\"\\(.*?\\)\" \"\\(.*?\\)\"" nil t) ; matches are in brackets
        (setq payees-list (cons (match-string-no-properties 1) ; get first match, generally the payee
                                payees-list))
        (setq payees-list (cons (match-string-no-properties 2) ; get second match, generally a description
                                payees-list))))
    (pcomplete-uniqify-list (nreverse payees-list))))

(defun beancount-get-tags-in-buffer ()
  "Return a list of all tags."
  (let ((origin (point))
        tags-list)
    (save-excursion
      (goto-char (point-min))
      (while (re-search-forward
              beancount-tag-regexp nil t)
        (setq tags-list (cons (substring (match-string-no-properties 0) 1)
                              tags-list))))
    (pcomplete-uniqify-list (nreverse tags-list))))

(defun beancount-get-commodities-in-buffer ()
  "Return a list of all commodities / currencies."
  (let ((origin (point))
        commodities-list)
    (save-excursion
      (goto-char (point-min))
      (while (re-search-forward
              "^[ ]+[A-Za-z0-9-_:]+[ ]+[-]?[0-9,.]+[ ]+\\([A-Z][A-Z0-9-_.']*[A-Z0-9]\\)" nil t)
        (setq commodities-list (cons (match-string-no-properties 1)
                                     commodities-list))))
    (pcomplete-uniqify-list (nreverse commodities-list))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Finishing setup

(defvar beancount-mode-map
  (let ((map  (make-sparse-keymap)))
    (define-key map [(meta ?p)] #'beancount-navigate-prev-xact-or-directive)
    (define-key map [(meta ?n)] #'beancount-navigate-next-xact-or-directive)
    map)
  "Keymap for `bean-mode'.")

(easy-menu-define beancount-mode-menu beancount-mode-map
  "Beancount menu"
  '("Beancount"
    ["Customize Ledger Mode" (lambda () (interactive) (customize-group 'beanmode))]))



;; (defun beancount-get-accounts (&optional string)
;;   "Return list of account names with STRING infix present.
;; STRING can be multiple words separated by a space."
;;   (let* ((accounts-string (shell-command-to-string
;;                            (concat "bean-query -q -f csv "
;;                                    "/home/marc/Archiv/Finanzen/transactions_ingdiba.beancount "
;;                                    "'SELECT DISTINCT account ORDER BY ACCOUNT ASC'")))
;;          (accounts-list (split-string accounts-string)))
;;     accounts-list))

(defvar beancount-accounts-cache nil
  "List of accounts cached for company mode.")

(defvar beancount-payees-cache nil
  "List of payees cached for company mode.")

(defvar beancount-tags-cache nil
  "List of tags cached for company mode.")

(defvar beancount-commodities-cache nil
  "List of commodities / currencies cached for company mode.")

(defun beancount-update-accounts-and-payees ()
  "Initialize or reset the list of accounts."
  (interactive)
  (setq beancount-accounts-cache (beancount-get-accounts-in-buffer)) ;-new
  (pcomplete-uniqify-list (nreverse beancount-accounts-cache))
;;  (setq beancount-accounts (beancount-get-accounts))
  (message "Accounts updated.")
  (setq beancount-payees-cache (beancount-get-payees-in-buffer)) ;-new
  (pcomplete-uniqify-list (nreverse beancount-payees-cache))
  (message "Payees updated.")
  (setq beancount-commodities-cache (beancount-get-commodities-in-buffer))
  (pcomplete-uniqify-list (nreverse beancount-commodities-cache))
  (setq beancount-tags-cache (beancount-get-tags-in-buffer))
  (pcomplete-uniqify-list (nreverse beancount-tags-cache))
  (message "Tags updated."))
;; first test for conditional completions
;; e.g. only account names when completion is after a date
;; (defun beancount-company-candidates (prefix)
;;   "Check what PREFIX does."
;;   (let* (accounts (beancount-accounts-cache))
;;     accounts))

;;;###autoload
(defun company-beancount (command &optional arg &rest ignored)
  "Company backend for 'beancount-mode'.
COMMAND, ARG, and IGNORED the regular meanings."
  (interactive (list 'interactive))
  (message arg)
  (pcase command
    (`interactive (company-begin-backend 'company-beancount))
    (`prefix (and (eq major-mode 'beancount-mode)
                  (company-grab-symbol)))
    (`candidates
     (cond
      ;; if line ends with date and status, at max one quoted text, and an open quote, offer payees and explainations
      ((string-match-p beancount-valid-prefix-for-payee-completion-regex (thing-at-point 'line))
       (delq nil
             (mapcar (lambda (c)
;                       (and (string-prefix-p (substring arg 1) c) c)
                       (and (string-prefix-p arg c) c))
                     beancount-payees-cache)))
      ;; if line starts with date, offer directives
      ((string-match-p beancount-valid-prefix-for-directives-regex (thing-at-point 'line))
       (delq nil
             (mapcar (lambda (c)
                       (and (string-prefix-p arg c) c))
                     beancount-timestamped-directive-names)))
      ;; if line starts with date, status and payees, offer tags
      ((string-match-p beancount-valid-prefix-for-tag-completion-regex (thing-at-point 'line))
       (delq nil
             (mapcar (lambda (c)
                       (and (string-prefix-p (substring arg 1) c) c))
                     beancount-tags-cache)))
      ;; if line starts with accounts and amounts, offer commodities
      ((string-match-p (concat "^[ ]+[A-Za-z0-9-_:]+[ ]+[-]?[0-9,.]+[ ]+" beancount-currency-regexp) (thing-at-point 'line))
       (delq nil
             (mapcar (lambda (c)
                       (and (string-prefix-p arg c) c))
                     beancount-commodities-cache)))
      ;; if line is empty, offer accounts
      ((or (string-match-p "^\\s-+" (thing-at-point 'line))
           ;; if the preceding text is allowed before an account, offer accounts
           ;; TODO: Not yet working!
           (string-match-p beancount-timestamped-accounts-regexp (thing-at-point 'line)))
       (delq nil
             (mapcar (lambda (c)
                       (message c)
                       (and (string-prefix-p arg c) c))
                     beancount-accounts-cache)))
      ))))

;;;###autoload
(define-derived-mode beancount-mode text-mode "Beancount"
  "A mode for editing beancount files.
\\{beancount-mode-map}"
  :init-value nil
  :lighter " Beancount"
  :group 'beancount

  ;; customize font-lock for beancount.
  (set-syntax-table beancount-mode-syntax-table)
  (font-lock-add-keywords nil beancount-font-lock-directives)

  (or beancount-accounts-cache
      (setq beancount-accounts-cache (beancount-get-accounts-in-buffer))) ;-new
  (or beancount-payees-cache
      (setq beancount-payees-cache (beancount-get-payees-in-buffer)))
  (or beancount-commodities-cache
      (setq beancount-commodities-cache (beancount-get-commodities-in-buffer)))
  (or beancount-tags-cache
      (setq beancount-tags-cache (beancount-get-tags-in-buffer)))
)


(provide 'beancount)

;;; beancount-mode.el ends here