ledger-complete.el (17567B)
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 (while (re-search-forward ledger-account-any-status-regex end t) 146 (let ((account (match-string-no-properties 1))) 147 (unless (gethash account seen) 148 (puthash account t seen) 149 (push (cons account nil) account-list)))))))) 150 (sort account-list (lambda (a b) (string-lessp (car a) (car b))))))) 151 152 (defun ledger-accounts-list-in-buffer () 153 "Return a list of all known account names in the current buffer as strings. 154 Considers both accounts listed in postings and those declared 155 with \"account\" directives." 156 (let ((accounts (ledger-accounts-in-buffer))) 157 (when ledger-accounts-exclude-function 158 (setq accounts (cl-remove-if ledger-accounts-exclude-function accounts))) 159 (mapcar #'car accounts))) 160 161 (defun ledger-accounts-list () 162 "Return a list of all known account names as strings. 163 Looks in `ledger-accounts-file' if set, otherwise the current buffer." 164 (if ledger-accounts-file 165 (let ((f ledger-accounts-file)) 166 (with-temp-buffer 167 (insert-file-contents f) 168 (ledger-accounts-list-in-buffer))) 169 (ledger-accounts-list-in-buffer))) 170 171 (defun ledger-accounts-tree () 172 "Return a tree of all accounts in the buffer. 173 174 Each node in the tree is a list (t . CHILDREN), where CHILDREN is 175 an alist (ACCOUNT-ELEMENT . NODE)." 176 (let ((account-tree (list t))) 177 (dolist (account (ledger-accounts-list) account-tree) 178 (let ((root account-tree) 179 (account-elements (split-string account ":"))) 180 (dolist (element account-elements) 181 (let ((node (assoc element root))) 182 (unless node 183 (setq node (cons element (list t))) 184 (nconc root (list node))) 185 (setq root (cdr node)))))))) 186 187 (defun ledger-complete-account-next-steps () 188 "Return a list of next steps for the account prefix at point." 189 ;; FIXME: This function is called from `ledger-complete-at-point' which 190 ;; already knows the bounds of the account name to complete. Computing it 191 ;; again here is wasteful. 192 (let* ((current (buffer-substring 193 (save-excursion 194 (unless (eq 'posting (ledger-thing-at-point)) 195 (error "Not on a posting line")) 196 (point)) 197 (point))) 198 (elements (and current (split-string current ":"))) 199 (root (ledger-accounts-tree)) 200 (prefix nil)) 201 (while (cdr elements) 202 (let ((xact (assoc (car elements) root))) 203 (if xact 204 (setq prefix (concat prefix (and prefix ":") 205 (car elements)) 206 root (cdr xact)) 207 (setq root nil elements nil))) 208 (setq elements (cdr elements))) 209 (setq root (delete (list (car elements) t) root)) 210 (and root 211 (sort 212 (mapcar (function 213 (lambda (x) 214 (let ((term (if prefix 215 (concat prefix ":" (car x)) 216 (car x)))) 217 (if (> (length (cdr x)) 1) 218 (concat term ":") 219 term)))) 220 (cdr root)) 221 'string-lessp)))) 222 223 (defvar ledger-complete--current-time-for-testing nil 224 "Internal, used for testing only.") 225 226 (defun ledger-complete-date (month-string day-string date-at-eol-p) 227 "Complete a date." 228 (let* ((now (or ledger-complete--current-time-for-testing (current-time))) 229 (decoded (decode-time now)) 230 (this-month (nth 4 decoded)) 231 (this-year (nth 5 decoded)) 232 (last-month (if (> this-month 1) (1- this-month) 12)) 233 (last-year (1- this-year)) 234 (last-month-year (if (> this-month 1) this-year last-year)) 235 (month (and month-string 236 (string-to-number month-string))) 237 (day (string-to-number day-string)) 238 (dates (list (encode-time 0 0 0 day (or month this-month) this-year) 239 (if month 240 (encode-time 0 0 0 day month last-year) 241 (encode-time 0 0 0 day last-month last-month-year))))) 242 (let ((collection 243 (list (concat (ledger-format-date 244 (cl-find-if (lambda (date) (not (time-less-p now date))) dates)) 245 (when date-at-eol-p " "))))) 246 (lambda (string predicate action) 247 (if (eq action 'metadata) 248 '(metadata (category . ledger-date)) 249 (complete-with-action action collection string predicate)))))) 250 251 (defun ledger-complete-effective-date 252 (tx-year-string tx-month-string tx-day-string 253 month-string day-string 254 date-at-eol-p) 255 "Complete an effective date." 256 (let* ((tx-year (string-to-number tx-year-string)) 257 (tx-month (string-to-number tx-month-string)) 258 (tx-day (string-to-number tx-day-string)) 259 (tx-date (encode-time 0 0 0 tx-day tx-month tx-year)) 260 (next-month (if (< tx-month 12) (1+ tx-month) 1)) 261 (next-year (1+ tx-year)) 262 (next-month-year (if (< tx-month 12) tx-year next-year)) 263 (month (and month-string 264 (string-to-number month-string))) 265 (day (string-to-number day-string)) 266 (dates (list (encode-time 0 0 0 day (or month tx-month) tx-year) 267 (if month 268 (encode-time 0 0 0 day month next-year) 269 (encode-time 0 0 0 day next-month next-month-year))))) 270 (let ((collection 271 (list (concat (ledger-format-date 272 (cl-find-if (lambda (date) (not (time-less-p date tx-date))) dates)) 273 (when date-at-eol-p " "))))) 274 (lambda (string predicate action) 275 (if (eq action 'metadata) 276 '(metadata (category . ledger-date)) 277 (complete-with-action action collection string predicate)))))) 278 279 (defun ledger-complete-at-point () 280 "Do appropriate completion for the thing at point." 281 (let ((end (point)) 282 start collection 283 realign-after 284 delete-suffix) 285 (cond (;; Date 286 (save-excursion 287 (skip-chars-forward "0-9/-") 288 (looking-back (concat "^" ledger-incomplete-date-regexp) (line-beginning-position))) 289 (setq collection (ledger-complete-date (match-string 1) 290 (match-string 2) 291 (= (line-end-position) (match-end 0))) 292 start (match-beginning 0) 293 ;; FIXME: This delete-suffix-post-completion behavior is weird 294 ;; and doesn't integrate well with different completion styles. 295 ;; For example, it breaks partial-completion's behavior when in 296 ;; the middle of the identifier. 297 ;; 298 ;; Instead, it should be implemented as an alternative 299 ;; completion style which is like emacs22 but discards the 300 ;; suffix. Or perhaps ledger-mode might rebind TAB to some key 301 ;; that deletes the account at point and then calls completion. 302 delete-suffix (save-match-data 303 (when (looking-at (rx (one-or-more (or digit (any ?/ ?-))))) 304 (length (match-string 0)))))) 305 (;; Effective dates 306 (save-excursion 307 (skip-chars-forward "0-9/-") 308 (looking-back (concat "^" ledger-iso-date-regexp "=" ledger-incomplete-date-regexp) 309 (line-beginning-position))) 310 (setq start (line-beginning-position)) 311 (setq collection (ledger-complete-effective-date 312 (match-string 2) (match-string 3) (match-string 4) 313 (match-string 5) (match-string 6) 314 (= (line-end-position) (match-end 0))))) 315 (;; Payees 316 (eq 'transaction 317 (save-excursion 318 (prog1 (ledger-thing-at-point) 319 (setq start (point))))) 320 (setq collection (cons 'nullary #'ledger-payees-list))) 321 (;; Accounts 322 (save-excursion 323 (back-to-indentation) 324 (skip-chars-forward "([") ;; for virtual accounts 325 (setq start (point))) 326 (setq delete-suffix (save-excursion 327 (when (search-forward-regexp 328 (rx (or eol (any "\t])") (repeat 2 space))) 329 (line-end-position) t) 330 (- (match-beginning 0) end))) 331 realign-after t 332 collection (cons 'nullary 333 (if ledger-complete-in-steps 334 #'ledger-complete-account-next-steps 335 #'ledger-accounts-list))))) 336 (when collection 337 (let ((prefix (buffer-substring-no-properties start end))) 338 (list start end 339 (pcase collection 340 ;; `func-arity' isn't available until Emacs 26, so we have to 341 ;; manually track the arity of the functions. 342 (`(nullary . ,f) 343 ;; a nullary function that returns a completion collection 344 (completion-table-with-cache 345 (lambda (_) 346 (cl-remove-if (apply-partially 'string= prefix) (funcall f))))) 347 ((pred functionp) 348 ;; a completion table 349 collection) 350 (_ 351 ;; a static completion collection 352 collection)) 353 :exit-function (lambda (&rest _) 354 (when delete-suffix 355 (delete-char delete-suffix)) 356 (when (and realign-after ledger-post-auto-align) 357 (ledger-post-align-postings (line-beginning-position) (line-end-position))))))))) 358 359 (defun ledger-trim-trailing-whitespace (str) 360 (replace-regexp-in-string "[ \t]*$" "" str)) 361 362 (defun ledger-fully-complete-xact () 363 "Completes a transaction if there is another matching payee in the buffer. 364 365 Interactively, if point is after a payee, complete the 366 transaction with the details from the last transaction to that 367 payee." 368 (interactive) 369 (let* ((name (ledger-trim-trailing-whitespace 370 (buffer-substring 371 (save-excursion 372 (unless (eq (ledger-thing-at-point) 'transaction) 373 (user-error "Cannot fully complete xact here")) 374 (point)) 375 (point)))) 376 (rest-of-name name) 377 xacts) 378 (save-excursion 379 (when (eq 'transaction (ledger-thing-at-point)) 380 (delete-region (point) (+ (length name) (point))) 381 ;; Search backward for a matching payee 382 (when (re-search-backward 383 (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.*" 384 (regexp-quote name) ".*\\)") 385 nil t) 386 (setq rest-of-name (match-string 3)) 387 ;; Start copying the postings 388 (forward-line) 389 (setq xacts (buffer-substring-no-properties (point) (ledger-navigate-end-of-xact)))))) 390 ;; Insert rest-of-name and the postings 391 (save-excursion 392 (insert rest-of-name ?\n) 393 (insert xacts) 394 (unless (looking-at-p "\n\n") 395 (insert "\n"))) 396 (forward-line) 397 (end-of-line) 398 ;; Move to amount on first posting line 399 (when (re-search-backward "\t\\| [ \t]" nil t) 400 (goto-char (match-end 0))))) 401 402 (add-to-list 'completion-category-defaults '(ledger-date (styles . (substring)))) 403 404 (provide 'ledger-complete) 405 406 ;;; ledger-complete.el ends here