From 374ae3de24187512adddf01a56e5eb52c79db65f Mon Sep 17 00:00:00 2001 From: Blendoit Date: Sat, 1 Aug 2020 15:18:40 -0700 Subject: Include contents of elpa/ sources + theme update. --- elpa/ledger-mode-20200530.1710/ledger-complete.el | 362 ++++++++++++++++++++++ 1 file changed, 362 insertions(+) create mode 100644 elpa/ledger-mode-20200530.1710/ledger-complete.el (limited to 'elpa/ledger-mode-20200530.1710/ledger-complete.el') diff --git a/elpa/ledger-mode-20200530.1710/ledger-complete.el b/elpa/ledger-mode-20200530.1710/ledger-complete.el new file mode 100644 index 0000000..2bf2cec --- /dev/null +++ b/elpa/ledger-mode-20200530.1710/ledger-complete.el @@ -0,0 +1,362 @@ +;;; 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 -- cgit v1.2.3