diff options
Diffstat (limited to 'elpa/ledger-mode-20200530.1710/ledger-complete.el')
| -rw-r--r-- | elpa/ledger-mode-20200530.1710/ledger-complete.el | 362 |
1 files changed, 0 insertions, 362 deletions
diff --git a/elpa/ledger-mode-20200530.1710/ledger-complete.el b/elpa/ledger-mode-20200530.1710/ledger-complete.el deleted file mode 100644 index 2bf2cec..0000000 --- a/elpa/ledger-mode-20200530.1710/ledger-complete.el +++ /dev/null @@ -1,362 +0,0 @@ -;;; 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 - (looking-back (rx-to-string `(seq bol (one-or-more space) - (optional (any ?\( ?\[ )) ;; for virtual accounts - (group (zero-or-more (not space))))) - (line-beginning-position)) - (setq start (match-beginning 1) - delete-suffix (save-excursion - (when (search-forward-regexp (rx (or eol (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 |