ledger-complete.el (15354B)
1 ;;; ledger-complete.el --- Helper code for use with the "ledger" command-line tool -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org) 4 5 ;; This file is not part of GNU Emacs. 6 7 ;; This is free software; you can redistribute it and/or modify it under 8 ;; the terms of the GNU General Public License as published by the Free 9 ;; Software Foundation; either version 2, or (at your option) any later 10 ;; version. 11 ;; 12 ;; This is distributed in the hope that it will be useful, but WITHOUT 13 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or 14 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15 ;; for more details. 16 ;; 17 ;; You should have received a copy of the GNU General Public License 18 ;; along with GNU Emacs; see the file COPYING. If not, write to the 19 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, 20 ;; MA 02110-1301 USA. 21 22 ;;; Commentary: 23 ;; Functions providing payee and account auto complete. 24 25 (require 'cl-lib) 26 (eval-when-compile 27 (require 'subr-x)) 28 29 ;; In-place completion support 30 31 ;;; Code: 32 (require 'ledger-context) 33 (require 'ledger-xact) 34 (require 'ledger-schedule) 35 36 (defcustom ledger-accounts-file nil 37 "The path to an optional file in which all accounts are used or declared. 38 This file will then be used as a source for account name 39 completions instead of the current file. 40 See ledger's \"account\" directive." 41 :type '(choice (const :tag "Use current buffer for completion" nil) 42 file) 43 :group 'ledger 44 :safe #'string-or-null-p) 45 46 (defcustom ledger-payees-file nil 47 "The path to an optional file in which all payees are used or declared. 48 This file will then be used as a source for payee name 49 completions instead of the current file. 50 See ledger's \"payee\" directive." 51 :type '(choice (const :tag "Use current buffer for completion" nil) 52 file) 53 :group 'ledger 54 :safe #'string-or-null-p) 55 56 (defcustom ledger-accounts-exclude-function nil 57 "Function to exclude accounts from completion. 58 Should be a predicate function that accepts one argument, an 59 element of `ledger-accounts-list-in-buffer'." 60 :type '(choice (const :tag "Do not exclude any accounts from completion" nil) 61 function) 62 :group 'ledger 63 :package-version '(ledger-mode . "2019-08-14")) 64 65 (defcustom ledger-complete-in-steps nil 66 "When non-nil, `ledger-complete-at-point' completes account names in steps. 67 If nil, full account names are offered for completion." 68 :type 'boolean 69 :group 'ledger 70 :package-version '(ledger-mode . "4.0.0")) 71 72 (defun ledger-payees-in-buffer () 73 "Scan buffer and return list of all payees." 74 (let ((origin (point)) 75 payees-list) 76 (save-excursion 77 (goto-char (point-min)) 78 (while (re-search-forward ledger-payee-name-or-directive-regex nil t) 79 (unless (and (>= origin (match-beginning 0)) 80 (< origin (match-end 0))) 81 (push (or (match-string-no-properties 1) (match-string-no-properties 2)) 82 payees-list)))) 83 ;; to the list 84 (sort (delete-dups payees-list) #'string-lessp))) 85 86 (defun ledger-payees-list () 87 "Return a list of all known account names as strings. 88 Looks in `ledger-payees-file' if set, otherwise the current buffer." 89 (if ledger-payees-file 90 (let ((f ledger-payees-file)) 91 (with-temp-buffer 92 (insert-file-contents f) 93 (ledger-payees-in-buffer))) 94 (ledger-payees-in-buffer))) 95 96 (defun ledger-accounts-in-buffer () 97 "Return an alist of accounts in the current buffer. 98 The `car' of each element is the account name and the `cdr' is an 99 alist where the key is a subdirective such as \"assert\" and the 100 value (if any) is the associated data. In other words, if you've 101 declared an account like so: 102 103 account Assets:Checking 104 assert commodity == \"$\" 105 default 106 107 Then one of the elements this function returns will be 108 \(\"Assets:Checking\" 109 (\"default\") 110 (\"assert\" . \"commodity == \"$\"\"))" 111 (save-excursion 112 (goto-char (point-min)) 113 (let (account-list 114 (seen (make-hash-table :test #'equal :size 1))) 115 ;; First, consider accounts declared with "account" directives, which may or 116 ;; may not have associated data. The data is on the following lines up to a 117 ;; line not starting with whitespace. 118 (while (re-search-forward ledger-account-directive-regex nil t) 119 (let ((account (match-string-no-properties 1)) 120 (lines (buffer-substring-no-properties 121 (point) 122 (progn (ledger-navigate-next-xact-or-directive) 123 (point)))) 124 data) 125 (dolist (d (split-string lines "\n")) 126 (setq d (string-trim d)) 127 (unless (string= d "") 128 (if (string-match " " d) 129 (push (cons (substring d 0 (match-beginning 0)) 130 (substring d (match-end 0) nil)) 131 data) 132 (push (cons d nil) data)))) 133 (push (cons account data) account-list) 134 (puthash account t seen))) 135 ;; Next, gather all accounts declared in postings 136 (unless 137 ;; FIXME: People who have set `ledger-flymake-be-pedantic' to non-nil 138 ;; probably don't want accounts from postings, just those declared 139 ;; with directives. But the name is a little misleading. Should we 140 ;; make a ledger-mode-be-pedantic and use that instead? 141 (bound-and-true-p ledger-flymake-be-pedantic) 142 (ledger-xact-iterate-transactions 143 (lambda (_pos _date _state _payee) 144 (let ((end (save-excursion (ledger-navigate-end-of-xact)))) 145 (forward-line) 146 (while (re-search-forward ledger-account-any-status-regex end t) 147 (let ((account (match-string-no-properties 1))) 148 (unless (gethash account seen) 149 (puthash account t seen) 150 (push (cons account nil) account-list)))))))) 151 (sort account-list (lambda (a b) (string-lessp (car a) (car b))))))) 152 153 (defun ledger-accounts-list-in-buffer () 154 "Return a list of all known account names in the current buffer as strings. 155 Considers both accounts listed in postings and those declared 156 with \"account\" directives." 157 (let ((accounts (ledger-accounts-in-buffer))) 158 (when ledger-accounts-exclude-function 159 (setq accounts (cl-remove-if ledger-accounts-exclude-function accounts))) 160 (mapcar #'car accounts))) 161 162 (defun ledger-accounts-list () 163 "Return a list of all known account names as strings. 164 Looks in `ledger-accounts-file' if set, otherwise the current buffer." 165 (if ledger-accounts-file 166 (let ((f ledger-accounts-file)) 167 (with-temp-buffer 168 (insert-file-contents f) 169 (ledger-accounts-list-in-buffer))) 170 (ledger-accounts-list-in-buffer))) 171 172 (defun ledger-accounts-tree () 173 "Return a tree of all accounts in the buffer. 174 175 Each node in the tree is a list (t . CHILDREN), where CHILDREN is 176 an alist (ACCOUNT-ELEMENT . NODE)." 177 (let ((account-tree (list t))) 178 (dolist (account (ledger-accounts-list) account-tree) 179 (let ((root account-tree) 180 (account-elements (split-string account ":"))) 181 (dolist (element account-elements) 182 (let ((node (assoc element root))) 183 (unless node 184 (setq node (cons element (list t))) 185 (nconc root (list node))) 186 (setq root (cdr node)))))))) 187 188 (defun ledger-complete-account-next-steps () 189 "Return a list of next steps for the account prefix at point." 190 ;; FIXME: This function is called from `ledger-complete-at-point' which 191 ;; already knows the bounds of the account name to complete. Computing it 192 ;; again here is wasteful. 193 (let* ((current (buffer-substring 194 (save-excursion 195 (unless (eq 'posting (ledger-thing-at-point)) 196 (error "Not on a posting line")) 197 (point)) 198 (point))) 199 (elements (and current (split-string current ":"))) 200 (root (ledger-accounts-tree)) 201 (prefix nil)) 202 (while (cdr elements) 203 (let ((xact (assoc (car elements) root))) 204 (if xact 205 (setq prefix (concat prefix (and prefix ":") 206 (car elements)) 207 root (cdr xact)) 208 (setq root nil elements nil))) 209 (setq elements (cdr elements))) 210 (setq root (delete (list (car elements) t) root)) 211 (and root 212 (sort 213 (mapcar (function 214 (lambda (x) 215 (let ((term (if prefix 216 (concat prefix ":" (car x)) 217 (car x)))) 218 (if (> (length (cdr x)) 1) 219 (concat term ":") 220 term)))) 221 (cdr root)) 222 'string-lessp)))) 223 224 (defun ledger-complete-date (month-string day-string) 225 "Complete a date." 226 (let* 227 ((now (current-time)) 228 (decoded (decode-time now)) 229 (this-month (nth 4 decoded)) 230 (this-year (nth 5 decoded)) 231 (last-month (if (> this-month 1) (1- this-month) 12)) 232 (last-year (1- this-year)) 233 (last-month-year (if (> this-month 1) this-year last-year)) 234 (month (and month-string 235 (string-to-number month-string))) 236 (day (string-to-number day-string)) 237 (dates (list (encode-time 0 0 0 day (or month this-month) this-year) 238 (if month 239 (encode-time 0 0 0 day month last-year) 240 (encode-time 0 0 0 day last-month last-month-year))))) 241 (lambda (_string _predicate _all) 242 (concat (ledger-format-date 243 (cl-find-if (lambda (date) (not (time-less-p now date))) dates)) 244 (and (= (point) (line-end-position)) " "))))) 245 246 (defun ledger-complete-effective-date 247 (tx-year-string tx-month-string tx-day-string 248 month-string day-string) 249 "Complete an effective date." 250 (let* 251 ((tx-year (string-to-number tx-year-string)) 252 (tx-month (string-to-number tx-month-string)) 253 (tx-day (string-to-number tx-day-string)) 254 (tx-date (encode-time 0 0 0 tx-day tx-month tx-year)) 255 (next-month (if (< tx-month 12) (1+ tx-month) 1)) 256 (next-year (1+ tx-year)) 257 (next-month-year (if (< tx-month 12) tx-year next-year)) 258 (month (and month-string 259 (string-to-number month-string))) 260 (day (string-to-number day-string)) 261 (dates (list (encode-time 0 0 0 day (or month tx-month) tx-year) 262 (if month 263 (encode-time 0 0 0 day month next-year) 264 (encode-time 0 0 0 day next-month next-month-year))))) 265 (lambda (_string _predicate _all) 266 (concat (ledger-format-date 267 (cl-find-if (lambda (date) (not (time-less-p date tx-date))) dates)) 268 (and (= (point) (line-end-position)) " "))))) 269 270 (defun ledger-complete-at-point () 271 "Do appropriate completion for the thing at point." 272 (let ((end (point)) 273 start collection 274 realign-after 275 delete-suffix) 276 (cond (;; Date 277 (looking-back (concat "^" ledger-incomplete-date-regexp) (line-beginning-position)) 278 (setq collection (ledger-complete-date (match-string 1) (match-string 2)) 279 start (match-beginning 0) 280 delete-suffix (save-match-data 281 (when (looking-at (rx (one-or-more (or digit (any ?/ ?-))))) 282 (length (match-string 0)))))) 283 (;; Effective dates 284 (looking-back (concat "^" ledger-iso-date-regexp "=" ledger-incomplete-date-regexp) 285 (line-beginning-position)) 286 (setq start (line-beginning-position)) 287 (setq collection (ledger-complete-effective-date 288 (match-string 2) (match-string 3) (match-string 4) 289 (match-string 5) (match-string 6)))) 290 (;; Payees 291 (eq 'transaction 292 (save-excursion 293 (prog1 (ledger-thing-at-point) 294 (setq start (point))))) 295 (setq collection #'ledger-payees-list)) 296 (;; Accounts 297 (save-excursion 298 (back-to-indentation) 299 (skip-chars-forward "([") ;; for virtual accounts 300 (setq start (point))) 301 (setq delete-suffix (save-excursion 302 (when (search-forward-regexp (rx (or eol (or ?\t (repeat 2 space)))) (line-end-position) t) 303 (- (match-beginning 0) end))) 304 realign-after t 305 collection (if ledger-complete-in-steps 306 #'ledger-complete-account-next-steps 307 #'ledger-accounts-list)))) 308 (when collection 309 (let ((prefix (buffer-substring-no-properties start end))) 310 (list start end 311 (if (functionp collection) 312 (completion-table-with-cache 313 (lambda (_) 314 (cl-remove-if (apply-partially 'string= prefix) (funcall collection)))) 315 collection) 316 :exit-function (lambda (&rest _) 317 (when delete-suffix 318 (delete-char delete-suffix)) 319 (when (and realign-after ledger-post-auto-align) 320 (ledger-post-align-postings (line-beginning-position) (line-end-position))))))))) 321 322 (defun ledger-trim-trailing-whitespace (str) 323 (replace-regexp-in-string "[ \t]*$" "" str)) 324 325 (defun ledger-fully-complete-xact () 326 "Completes a transaction if there is another matching payee in the buffer. 327 328 Interactively, if point is after a payee, complete the 329 transaction with the details from the last transaction to that 330 payee." 331 (interactive) 332 (let* ((name (ledger-trim-trailing-whitespace 333 (buffer-substring 334 (save-excursion 335 (unless (eq (ledger-thing-at-point) 'transaction) 336 (user-error "Cannot fully complete xact here")) 337 (point)) 338 (point)))) 339 (rest-of-name name) 340 xacts) 341 (save-excursion 342 (when (eq 'transaction (ledger-thing-at-point)) 343 (delete-region (point) (+ (length name) (point))) 344 ;; Search backward for a matching payee 345 (when (re-search-backward 346 (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.*" 347 (regexp-quote name) ".*\\)") 348 nil t) 349 (setq rest-of-name (match-string 3)) 350 ;; Start copying the postings 351 (forward-line) 352 (setq xacts (buffer-substring-no-properties (point) (ledger-navigate-end-of-xact)))))) 353 ;; Insert rest-of-name and the postings 354 (save-excursion 355 (insert rest-of-name ?\n) 356 (insert xacts) 357 (unless (looking-at-p "\n\n") 358 (insert "\n"))) 359 (forward-line) 360 (end-of-line) 361 ;; Move to amount on first posting line 362 (when (re-search-backward "\t\\| [ \t]" nil t) 363 (goto-char (match-end 0))))) 364 365 (provide 'ledger-complete) 366 367 ;;; ledger-complete.el ends here