ledger-complete.el

;;; 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."
  :type 'file
  :group 'ledger)

(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 '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-parse-arguments ()
  "Parse whitespace separated arguments in the current region."
  ;; FIXME: We don't use pcomplete anymore.
  ;; This is more complex than it appears
  ;; to need, so that it can work with pcomplete.  See
  ;; pcomplete-parse-arguments-function for details
  (let* ((begin (save-match-data
                  (if (looking-back (concat "^\\(" ledger-iso-date-regexp "=\\|\\)"
                                            ledger-incomplete-date-regexp) nil)
                      (match-end 1)
                    (save-excursion
                      (ledger-thing-at-point) ;; leave point at beginning of thing under point
                      (point)))))
         (end (point))
         begins args)
    ;; to support end of line metadata
    (save-excursion
      (when (search-backward ";"
                             (line-beginning-position) t)
        (setq begin (match-beginning 0))))
    (save-excursion
      (goto-char begin)
      (when (< (point) end)
        (skip-chars-forward " \t\n")
        (setq begins (cons (point) begins))
        (setq args (cons (buffer-substring-no-properties
                          (car begins) end)
                         args)))
      (cons (reverse args) (reverse begins)))))


(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-any-status-regex nil t)  ;; matches first line
        (unless (and (>= origin (match-beginning 0))
                     (< origin (match-end 0)))
          (setq payees-list (cons (match-string-no-properties 3)
                                  payees-list)))))  ;; add the payee
    ;; to the list
    (sort (delete-dups payees-list) #'string-lessp)))

(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)
        (goto-char (point-min))
        (while (re-search-forward ledger-account-name-or-directive-regex nil 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-find-accounts-in-buffer ()
  (let ((account-tree (list t))
        (account-elements nil)
        (prefix ""))
    (save-excursion
      (goto-char (point-min))

      (dolist (account
               (cl-remove-if-not (lambda (c) (string-prefix-p prefix c))
                                 (ledger-accounts-list)))
        (let ((root account-tree))
          (setq account-elements
                (split-string
                 account ":"))
          (while account-elements
            (let ((xact (assoc (car account-elements) root)))
              (if xact
                  (setq root (cdr xact))
                (setq xact (cons (car account-elements) (list t)))
                (nconc root (list xact))
                (setq root (cdr xact))))
            (setq account-elements (cdr account-elements))))))
    account-tree))

(defun ledger-accounts-tree ()
  "Return a tree of all accounts in the buffer."
  (let* ((current (caar (ledger-parse-arguments)))
         (elements (and current (split-string current ":")))
         (root (ledger-find-accounts-in-buffer))
         (prefix nil))
    (while (cdr elements)
      (let ((xact (assoc (car elements) root)))
        (if xact
            (setq prefix (concat prefix (and prefix ":")
                                 (car elements))
                  root (cdr xact))
          (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))))

(defun ledger-complete-date (month-string day-string)
  "Complete a date."
  (let*
      ((now (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)))))
    (lambda (_string _predicate _all)
      (concat (ledger-format-date
               (cl-find-if (lambda (date) (not (time-less-p now date))) dates))
              (and (= (point) (line-end-position)) " ")))))

(defun ledger-complete-effective-date
    (tx-year-string tx-month-string tx-day-string
                    month-string day-string)
  "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)))))
    (lambda (_string _predicate _all)
      (concat (ledger-format-date
               (cl-find-if (lambda (date) (not (time-less-p date tx-date))) dates))
              (and (= (point) (line-end-position)) " ")))))

(defun ledger-complete-at-point ()
  "Do appropriate completion for the thing at point."
  (let ((end (point))
        start collection
        realign-after
        delete-suffix)
    (cond (;; Date
           (looking-back (concat "^" ledger-incomplete-date-regexp) (line-beginning-position))
           (setq collection (ledger-complete-date (match-string 1) (match-string 2))
                 start (match-beginning 0)
                 delete-suffix (save-match-data
                                 (when (looking-at (rx (one-or-more (or digit (any ?/ ?-)))))
                                   (length (match-string 0))))))
          (;; Effective dates
           (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))))
          (;; Payees
           (eq (save-excursion (ledger-thing-at-point)) 'transaction)
           (setq start (save-excursion (backward-word) (point)))
           (setq collection #'ledger-payees-in-buffer))
          (;; 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 (or ?\t (repeat 2 space)))) (line-end-position) t)
                                   (- (match-beginning 0) end)))
                 realign-after t
                 collection (if ledger-complete-in-steps
                                #'ledger-accounts-tree
                              #'ledger-accounts-list))))
    (when collection
      (let ((prefix (buffer-substring-no-properties start end)))
        (list start end
              (if (functionp collection)
                  (completion-table-with-cache
                   (lambda (_)
                     (cl-remove-if (apply-partially 'string= prefix) (funcall 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))))
              'ignore)))))

(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 (caar (ledger-parse-arguments))))
         (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)
    (goto-char (line-end-position))
    (when (re-search-backward "\\(\t\\| [ \t]\\)" nil t)
      (goto-char (match-end 0)))))

(provide 'ledger-complete)

;;; ledger-complete.el ends here