400 lines
17 KiB
EmacsLisp
400 lines
17 KiB
EmacsLisp
;;; ledger-complete.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
|
|
|
|
;; This file is not part of GNU Emacs.
|
|
|
|
;; This 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 2, or (at your option) any later
|
|
;; version.
|
|
;;
|
|
;; This 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 GNU Emacs; see the file COPYING. If not, write to the
|
|
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
|
|
;; MA 02110-1301 USA.
|
|
|
|
;;; Commentary:
|
|
;; Functions providing payee and account auto complete.
|
|
|
|
(require 'cl-lib)
|
|
(eval-when-compile
|
|
(require 'subr-x))
|
|
|
|
;; In-place completion support
|
|
|
|
;;; Code:
|
|
(require 'ledger-context)
|
|
(require 'ledger-xact)
|
|
(require 'ledger-schedule)
|
|
|
|
(defcustom ledger-accounts-file nil
|
|
"The path to an optional file in which all accounts are used or declared.
|
|
This file will then be used as a source for account name
|
|
completions instead of the current file.
|
|
See ledger's \"account\" directive."
|
|
:type '(choice (const :tag "Use current buffer for completion" nil)
|
|
file)
|
|
:group 'ledger
|
|
:safe #'string-or-null-p)
|
|
|
|
(defcustom ledger-payees-file nil
|
|
"The path to an optional file in which all payees are used or declared.
|
|
This file will then be used as a source for payee name
|
|
completions instead of the current file.
|
|
See ledger's \"payee\" directive."
|
|
:type '(choice (const :tag "Use current buffer for completion" nil)
|
|
file)
|
|
:group 'ledger
|
|
:safe #'string-or-null-p)
|
|
|
|
(defcustom ledger-accounts-exclude-function nil
|
|
"Function to exclude accounts from completion.
|
|
Should be a predicate function that accepts one argument, an
|
|
element of `ledger-accounts-list-in-buffer'."
|
|
:type '(choice (const :tag "Do not exclude any accounts from completion" nil)
|
|
function)
|
|
:group 'ledger
|
|
:package-version '(ledger-mode . "2019-08-14"))
|
|
|
|
(defcustom ledger-complete-in-steps nil
|
|
"When non-nil, `ledger-complete-at-point' completes account names in steps.
|
|
If nil, full account names are offered for completion."
|
|
:type 'boolean
|
|
:group 'ledger
|
|
:package-version '(ledger-mode . "4.0.0"))
|
|
|
|
(defun ledger-payees-in-buffer ()
|
|
"Scan buffer and return list of all payees."
|
|
(let ((origin (point))
|
|
payees-list)
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(while (re-search-forward ledger-payee-name-or-directive-regex nil t)
|
|
(unless (and (>= origin (match-beginning 0))
|
|
(< origin (match-end 0)))
|
|
(push (or (match-string-no-properties 1) (match-string-no-properties 2))
|
|
payees-list))))
|
|
;; to the list
|
|
(sort (delete-dups payees-list) #'string-lessp)))
|
|
|
|
(defun ledger-payees-list ()
|
|
"Return a list of all known account names as strings.
|
|
Looks in `ledger-payees-file' if set, otherwise the current buffer."
|
|
(if ledger-payees-file
|
|
(let ((f ledger-payees-file))
|
|
(with-temp-buffer
|
|
(insert-file-contents f)
|
|
(ledger-payees-in-buffer)))
|
|
(ledger-payees-in-buffer)))
|
|
|
|
(defun ledger-accounts-in-buffer ()
|
|
"Return an alist of accounts in the current buffer.
|
|
The `car' of each element is the account name and the `cdr' is an
|
|
alist where the key is a subdirective such as \"assert\" and the
|
|
value (if any) is the associated data. In other words, if you've
|
|
declared an account like so:
|
|
|
|
account Assets:Checking
|
|
assert commodity == \"$\"
|
|
default
|
|
|
|
Then one of the elements this function returns will be
|
|
\(\"Assets:Checking\"
|
|
(\"default\")
|
|
(\"assert\" . \"commodity == \"$\"\"))"
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(let (account-list
|
|
(seen (make-hash-table :test #'equal :size 1)))
|
|
;; First, consider accounts declared with "account" directives, which may or
|
|
;; may not have associated data. The data is on the following lines up to a
|
|
;; line not starting with whitespace.
|
|
(while (re-search-forward ledger-account-directive-regex nil t)
|
|
(let ((account (match-string-no-properties 1))
|
|
(lines (buffer-substring-no-properties
|
|
(point)
|
|
(progn (ledger-navigate-next-xact-or-directive)
|
|
(point))))
|
|
data)
|
|
(dolist (d (split-string lines "\n"))
|
|
(setq d (string-trim d))
|
|
(unless (string= d "")
|
|
(if (string-match " " d)
|
|
(push (cons (substring d 0 (match-beginning 0))
|
|
(substring d (match-end 0) nil))
|
|
data)
|
|
(push (cons d nil) data))))
|
|
(push (cons account data) account-list)
|
|
(puthash account t seen)))
|
|
;; Next, gather all accounts declared in postings
|
|
(unless
|
|
;; FIXME: People who have set `ledger-flymake-be-pedantic' to non-nil
|
|
;; probably don't want accounts from postings, just those declared
|
|
;; with directives. But the name is a little misleading. Should we
|
|
;; make a ledger-mode-be-pedantic and use that instead?
|
|
(bound-and-true-p ledger-flymake-be-pedantic)
|
|
(ledger-xact-iterate-transactions
|
|
(lambda (_pos _date _state _payee)
|
|
(let ((end (save-excursion (ledger-navigate-end-of-xact))))
|
|
(while (re-search-forward ledger-account-any-status-regex end t)
|
|
(let ((account (match-string-no-properties 1)))
|
|
(unless (gethash account seen)
|
|
(puthash account t seen)
|
|
(push (cons account nil) account-list))))))))
|
|
(sort account-list (lambda (a b) (string-lessp (car a) (car b)))))))
|
|
|
|
(defun ledger-accounts-list-in-buffer ()
|
|
"Return a list of all known account names in the current buffer as strings.
|
|
Considers both accounts listed in postings and those declared
|
|
with \"account\" directives."
|
|
(let ((accounts (ledger-accounts-in-buffer)))
|
|
(when ledger-accounts-exclude-function
|
|
(setq accounts (cl-remove-if ledger-accounts-exclude-function accounts)))
|
|
(mapcar #'car accounts)))
|
|
|
|
(defun ledger-accounts-list ()
|
|
"Return a list of all known account names as strings.
|
|
Looks in `ledger-accounts-file' if set, otherwise the current buffer."
|
|
(if ledger-accounts-file
|
|
(let ((f ledger-accounts-file))
|
|
(with-temp-buffer
|
|
(insert-file-contents f)
|
|
(ledger-accounts-list-in-buffer)))
|
|
(ledger-accounts-list-in-buffer)))
|
|
|
|
(defun ledger-accounts-tree ()
|
|
"Return a tree of all accounts in the buffer.
|
|
|
|
Each node in the tree is a list (t . CHILDREN), where CHILDREN is
|
|
an alist (ACCOUNT-ELEMENT . NODE)."
|
|
(let ((account-tree (list t)))
|
|
(dolist (account (ledger-accounts-list) account-tree)
|
|
(let ((root account-tree)
|
|
(account-elements (split-string account ":")))
|
|
(dolist (element account-elements)
|
|
(let ((node (assoc element root)))
|
|
(unless node
|
|
(setq node (cons element (list t)))
|
|
(nconc root (list node)))
|
|
(setq root (cdr node))))))))
|
|
|
|
(defun ledger-complete-account-next-steps (start end)
|
|
"Return a list of next steps for the account prefix between START and END."
|
|
(let* ((current (buffer-substring start end))
|
|
(elements (and current (split-string current ":")))
|
|
(root (ledger-accounts-tree))
|
|
(prefix nil))
|
|
(while (cdr elements)
|
|
(let ((entry (assoc (car elements) root)))
|
|
(if entry
|
|
(setq prefix (concat prefix (and prefix ":")
|
|
(car elements))
|
|
root (cdr entry))
|
|
(setq root nil elements nil)))
|
|
(setq elements (cdr elements)))
|
|
(setq root (delete (list (car elements) t) root))
|
|
(and root
|
|
(sort
|
|
(mapcar (function
|
|
(lambda (x)
|
|
(let ((term (if prefix
|
|
(concat prefix ":" (car x))
|
|
(car x))))
|
|
(if (> (length (cdr x)) 1)
|
|
(concat term ":")
|
|
term))))
|
|
(cdr root))
|
|
'string-lessp))))
|
|
|
|
(defvar ledger-complete--current-time-for-testing nil
|
|
"Internal, used for testing only.")
|
|
|
|
(defun ledger-complete-date (month-string day-string date-at-eol-p)
|
|
"Complete a date."
|
|
(let* ((now (or ledger-complete--current-time-for-testing (current-time)))
|
|
(decoded (decode-time now))
|
|
(this-month (nth 4 decoded))
|
|
(this-year (nth 5 decoded))
|
|
(last-month (if (> this-month 1) (1- this-month) 12))
|
|
(last-year (1- this-year))
|
|
(last-month-year (if (> this-month 1) this-year last-year))
|
|
(month (and month-string
|
|
(string-to-number month-string)))
|
|
(day (string-to-number day-string))
|
|
(dates (list (encode-time 0 0 0 day (or month this-month) this-year)
|
|
(if month
|
|
(encode-time 0 0 0 day month last-year)
|
|
(encode-time 0 0 0 day last-month last-month-year)))))
|
|
(let ((collection
|
|
(list (concat (ledger-format-date
|
|
(cl-find-if (lambda (date) (not (time-less-p now date))) dates))
|
|
(when date-at-eol-p " ")))))
|
|
(lambda (string predicate action)
|
|
(if (eq action 'metadata)
|
|
'(metadata (category . ledger-date))
|
|
(complete-with-action action collection string predicate))))))
|
|
|
|
(defun ledger-complete-effective-date
|
|
(tx-year-string tx-month-string tx-day-string
|
|
month-string day-string
|
|
date-at-eol-p)
|
|
"Complete an effective date."
|
|
(let* ((tx-year (string-to-number tx-year-string))
|
|
(tx-month (string-to-number tx-month-string))
|
|
(tx-day (string-to-number tx-day-string))
|
|
(tx-date (encode-time 0 0 0 tx-day tx-month tx-year))
|
|
(next-month (if (< tx-month 12) (1+ tx-month) 1))
|
|
(next-year (1+ tx-year))
|
|
(next-month-year (if (< tx-month 12) tx-year next-year))
|
|
(month (and month-string
|
|
(string-to-number month-string)))
|
|
(day (string-to-number day-string))
|
|
(dates (list (encode-time 0 0 0 day (or month tx-month) tx-year)
|
|
(if month
|
|
(encode-time 0 0 0 day month next-year)
|
|
(encode-time 0 0 0 day next-month next-month-year)))))
|
|
(let ((collection
|
|
(list (concat (ledger-format-date
|
|
(cl-find-if (lambda (date) (not (time-less-p date tx-date))) dates))
|
|
(when date-at-eol-p " ")))))
|
|
(lambda (string predicate action)
|
|
(if (eq action 'metadata)
|
|
'(metadata (category . ledger-date))
|
|
(complete-with-action action collection string predicate))))))
|
|
|
|
(defun ledger-complete-at-point ()
|
|
"Do appropriate completion for the thing at point."
|
|
(let ((end (point))
|
|
start collection
|
|
realign-after
|
|
delete-suffix)
|
|
(cond (;; Date
|
|
(save-excursion
|
|
(skip-chars-forward "0-9/-")
|
|
(looking-back (concat "^" ledger-incomplete-date-regexp) (line-beginning-position)))
|
|
(setq collection (ledger-complete-date (match-string 1)
|
|
(match-string 2)
|
|
(= (line-end-position) (match-end 0)))
|
|
start (match-beginning 0)
|
|
;; FIXME: This delete-suffix-post-completion behavior is weird
|
|
;; and doesn't integrate well with different completion styles.
|
|
;; For example, it breaks partial-completion's behavior when in
|
|
;; the middle of the identifier.
|
|
;;
|
|
;; Instead, it should be implemented as an alternative
|
|
;; completion style which is like emacs22 but discards the
|
|
;; suffix. Or perhaps ledger-mode might rebind TAB to some key
|
|
;; that deletes the account at point and then calls completion.
|
|
delete-suffix (save-match-data
|
|
(when (looking-at (rx (one-or-more (or digit (any ?/ ?-)))))
|
|
(length (match-string 0))))))
|
|
(;; Effective dates
|
|
(save-excursion
|
|
(skip-chars-forward "0-9/-")
|
|
(looking-back (concat "^" ledger-iso-date-regexp "=" ledger-incomplete-date-regexp)
|
|
(line-beginning-position)))
|
|
(setq start (line-beginning-position))
|
|
(setq collection (ledger-complete-effective-date
|
|
(match-string 2) (match-string 3) (match-string 4)
|
|
(match-string 5) (match-string 6)
|
|
(= (line-end-position) (match-end 0)))))
|
|
(;; Payees
|
|
(eq 'transaction
|
|
(save-excursion
|
|
(prog1 (ledger-thing-at-point)
|
|
(setq start (point)))))
|
|
(setq collection (cons 'nullary #'ledger-payees-list)))
|
|
(;; Accounts
|
|
(save-excursion
|
|
(back-to-indentation)
|
|
(skip-chars-forward "([") ;; for virtual accounts
|
|
(setq start (point)))
|
|
(setq delete-suffix (save-excursion
|
|
(when (search-forward-regexp
|
|
(rx (or eol (any "\t])") (repeat 2 space)))
|
|
(line-end-position) t)
|
|
(- (match-beginning 0) end)))
|
|
realign-after t
|
|
collection (cons 'nullary
|
|
(if ledger-complete-in-steps
|
|
(lambda ()
|
|
(ledger-complete-account-next-steps start end))
|
|
#'ledger-accounts-list)))))
|
|
(when collection
|
|
(let ((prefix (buffer-substring-no-properties start end)))
|
|
(list start end
|
|
(pcase collection
|
|
;; `func-arity' isn't available until Emacs 26, so we have to
|
|
;; manually track the arity of the functions.
|
|
(`(nullary . ,f)
|
|
;; a nullary function that returns a completion collection
|
|
(completion-table-with-cache
|
|
(lambda (_)
|
|
(cl-remove-if (apply-partially 'string= prefix) (funcall f)))))
|
|
((pred functionp)
|
|
;; a completion table
|
|
collection)
|
|
(_
|
|
;; a static completion collection
|
|
collection))
|
|
:exit-function (lambda (&rest _)
|
|
(when delete-suffix
|
|
(delete-char delete-suffix))
|
|
(when (and realign-after ledger-post-auto-align)
|
|
(ledger-post-align-postings (line-beginning-position) (line-end-position)))))))))
|
|
|
|
(defun ledger-trim-trailing-whitespace (str)
|
|
(replace-regexp-in-string "[ \t]*$" "" str))
|
|
|
|
(defun ledger-fully-complete-xact ()
|
|
"Completes a transaction if there is another matching payee in the buffer.
|
|
|
|
Interactively, if point is after a payee, complete the
|
|
transaction with the details from the last transaction to that
|
|
payee."
|
|
(interactive)
|
|
(let* ((name (ledger-trim-trailing-whitespace
|
|
(buffer-substring
|
|
(save-excursion
|
|
(unless (eq (ledger-thing-at-point) 'transaction)
|
|
(user-error "Cannot fully complete xact here"))
|
|
(point))
|
|
(point))))
|
|
(rest-of-name name)
|
|
xacts)
|
|
(save-excursion
|
|
(when (eq 'transaction (ledger-thing-at-point))
|
|
(delete-region (point) (+ (length name) (point)))
|
|
;; Search backward for a matching payee
|
|
(when (re-search-backward
|
|
(concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.*"
|
|
(regexp-quote name) ".*\\)")
|
|
nil t)
|
|
(setq rest-of-name (match-string 3))
|
|
;; Start copying the postings
|
|
(forward-line)
|
|
(setq xacts (buffer-substring-no-properties (point) (ledger-navigate-end-of-xact))))))
|
|
;; Insert rest-of-name and the postings
|
|
(save-excursion
|
|
(insert rest-of-name ?\n)
|
|
(insert xacts)
|
|
(unless (looking-at-p "\n\n")
|
|
(insert "\n")))
|
|
(forward-line)
|
|
(end-of-line)
|
|
;; Move to amount on first posting line
|
|
(when (re-search-backward "\t\\| [ \t]" nil t)
|
|
(goto-char (match-end 0)))))
|
|
|
|
(add-to-list 'completion-category-defaults '(ledger-date (styles . (substring))))
|
|
|
|
(provide 'ledger-complete)
|
|
|
|
;;; ledger-complete.el ends here
|