ledger-complete.el (16889B)
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 (defvar ledger-complete--current-time-for-testing nil 225 "Internal, used for testing only.") 226 227 (defun ledger-complete-date (month-string day-string date-at-eol-p) 228 "Complete a date." 229 (let* ((now (or ledger-complete--current-time-for-testing (current-time))) 230 (decoded (decode-time now)) 231 (this-month (nth 4 decoded)) 232 (this-year (nth 5 decoded)) 233 (last-month (if (> this-month 1) (1- this-month) 12)) 234 (last-year (1- this-year)) 235 (last-month-year (if (> this-month 1) this-year last-year)) 236 (month (and month-string 237 (string-to-number month-string))) 238 (day (string-to-number day-string)) 239 (dates (list (encode-time 0 0 0 day (or month this-month) this-year) 240 (if month 241 (encode-time 0 0 0 day month last-year) 242 (encode-time 0 0 0 day last-month last-month-year))))) 243 (let ((collection 244 (list (concat (ledger-format-date 245 (cl-find-if (lambda (date) (not (time-less-p now date))) dates)) 246 (when date-at-eol-p " "))))) 247 (lambda (string predicate action) 248 (if (eq action 'metadata) 249 '(metadata (category . ledger-date)) 250 (complete-with-action action collection string predicate)))))) 251 252 (defun ledger-complete-effective-date 253 (tx-year-string tx-month-string tx-day-string 254 month-string day-string 255 date-at-eol-p) 256 "Complete an effective date." 257 (let* ((tx-year (string-to-number tx-year-string)) 258 (tx-month (string-to-number tx-month-string)) 259 (tx-day (string-to-number tx-day-string)) 260 (tx-date (encode-time 0 0 0 tx-day tx-month tx-year)) 261 (next-month (if (< tx-month 12) (1+ tx-month) 1)) 262 (next-year (1+ tx-year)) 263 (next-month-year (if (< tx-month 12) tx-year next-year)) 264 (month (and month-string 265 (string-to-number month-string))) 266 (day (string-to-number day-string)) 267 (dates (list (encode-time 0 0 0 day (or month tx-month) tx-year) 268 (if month 269 (encode-time 0 0 0 day month next-year) 270 (encode-time 0 0 0 day next-month next-month-year))))) 271 (let ((collection 272 (list (concat (ledger-format-date 273 (cl-find-if (lambda (date) (not (time-less-p date tx-date))) dates)) 274 (when date-at-eol-p " "))))) 275 (lambda (string predicate action) 276 (if (eq action 'metadata) 277 '(metadata (category . ledger-date)) 278 (complete-with-action action collection string predicate)))))) 279 280 (defun ledger-complete-at-point () 281 "Do appropriate completion for the thing at point." 282 (let ((end (point)) 283 start collection 284 realign-after 285 delete-suffix) 286 (cond (;; Date 287 (save-excursion 288 (skip-chars-forward "0-9/-") 289 (looking-back (concat "^" ledger-incomplete-date-regexp) (line-beginning-position))) 290 (setq collection (ledger-complete-date (match-string 1) 291 (match-string 2) 292 (= (line-end-position) (match-end 0))) 293 start (match-beginning 0) 294 delete-suffix (save-match-data 295 (when (looking-at (rx (one-or-more (or digit (any ?/ ?-))))) 296 (length (match-string 0)))))) 297 (;; Effective dates 298 (save-excursion 299 (skip-chars-forward "0-9/-") 300 (looking-back (concat "^" ledger-iso-date-regexp "=" ledger-incomplete-date-regexp) 301 (line-beginning-position))) 302 (setq start (line-beginning-position)) 303 (setq collection (ledger-complete-effective-date 304 (match-string 2) (match-string 3) (match-string 4) 305 (match-string 5) (match-string 6) 306 (= (line-end-position) (match-end 0))))) 307 (;; Payees 308 (eq 'transaction 309 (save-excursion 310 (prog1 (ledger-thing-at-point) 311 (setq start (point))))) 312 (setq collection (cons 'nullary #'ledger-payees-list))) 313 (;; Accounts 314 (save-excursion 315 (back-to-indentation) 316 (skip-chars-forward "([") ;; for virtual accounts 317 (setq start (point))) 318 (setq delete-suffix (save-excursion 319 (when (search-forward-regexp (rx (or eol (or ?\t (repeat 2 space)))) (line-end-position) t) 320 (- (match-beginning 0) end))) 321 realign-after t 322 collection (cons 'nullary 323 (if ledger-complete-in-steps 324 #'ledger-complete-account-next-steps 325 #'ledger-accounts-list))))) 326 (when collection 327 (let ((prefix (buffer-substring-no-properties start end))) 328 (list start end 329 (pcase collection 330 ;; `func-arity' isn't available until Emacs 26, so we have to 331 ;; manually track the arity of the functions. 332 (`(nullary . ,f) 333 ;; a nullary function that returns a completion collection 334 (completion-table-with-cache 335 (lambda (_) 336 (cl-remove-if (apply-partially 'string= prefix) (funcall f))))) 337 ((pred functionp) 338 ;; a completion table 339 collection) 340 (_ 341 ;; a static completion collection 342 collection)) 343 :exit-function (lambda (&rest _) 344 (when delete-suffix 345 (delete-char delete-suffix)) 346 (when (and realign-after ledger-post-auto-align) 347 (ledger-post-align-postings (line-beginning-position) (line-end-position))))))))) 348 349 (defun ledger-trim-trailing-whitespace (str) 350 (replace-regexp-in-string "[ \t]*$" "" str)) 351 352 (defun ledger-fully-complete-xact () 353 "Completes a transaction if there is another matching payee in the buffer. 354 355 Interactively, if point is after a payee, complete the 356 transaction with the details from the last transaction to that 357 payee." 358 (interactive) 359 (let* ((name (ledger-trim-trailing-whitespace 360 (buffer-substring 361 (save-excursion 362 (unless (eq (ledger-thing-at-point) 'transaction) 363 (user-error "Cannot fully complete xact here")) 364 (point)) 365 (point)))) 366 (rest-of-name name) 367 xacts) 368 (save-excursion 369 (when (eq 'transaction (ledger-thing-at-point)) 370 (delete-region (point) (+ (length name) (point))) 371 ;; Search backward for a matching payee 372 (when (re-search-backward 373 (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.*" 374 (regexp-quote name) ".*\\)") 375 nil t) 376 (setq rest-of-name (match-string 3)) 377 ;; Start copying the postings 378 (forward-line) 379 (setq xacts (buffer-substring-no-properties (point) (ledger-navigate-end-of-xact)))))) 380 ;; Insert rest-of-name and the postings 381 (save-excursion 382 (insert rest-of-name ?\n) 383 (insert xacts) 384 (unless (looking-at-p "\n\n") 385 (insert "\n"))) 386 (forward-line) 387 (end-of-line) 388 ;; Move to amount on first posting line 389 (when (re-search-backward "\t\\| [ \t]" nil t) 390 (goto-char (match-end 0))))) 391 392 (add-to-list 'completion-category-defaults '(ledger-date (styles . (substring)))) 393 394 (provide 'ledger-complete) 395 396 ;;; ledger-complete.el ends here