ledger-complete.el (16062B)
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 41 \"account\" directive." 42 :type '(choice (const :tag "Use current buffer for completion" nil) 43 file) 44 :group 'ledger 45 :safe #'string-or-null-p) 46 47 (defcustom ledger-payees-file nil 48 "The path to an optional file in which all payees are used or declared. 49 This file will then be used as a source for payee name 50 completions instead of the current file. 51 See ledger's \"payee\" directive." 52 :type '(choice (const :tag "Use current buffer for completion" nil) 53 file) 54 :group 'ledger 55 :safe #'string-or-null-p) 56 57 (defcustom ledger-accounts-exclude-function nil 58 "Function to exclude accounts from completion. 59 Should be a predicate function that accepts one argument, an 60 element of `ledger-accounts-list-in-buffer'." 61 :type '(choice (const :tag "Do not exclude any accounts from completion" nil) 62 function) 63 :group 'ledger 64 :package-version '(ledger-mode . "2019-08-14")) 65 66 (defcustom ledger-complete-in-steps nil 67 "When non-nil, `ledger-complete-at-point' completes account names in steps. 68 If nil, full account names are offered for completion." 69 :type 'boolean 70 :group 'ledger 71 :package-version '(ledger-mode . "4.0.0")) 72 73 (defun ledger-parse-arguments () 74 "Parse whitespace separated arguments in the current region." 75 ;; FIXME: We don't use pcomplete anymore. 76 ;; This is more complex than it appears 77 ;; to need, so that it can work with pcomplete. See 78 ;; pcomplete-parse-arguments-function for details 79 (let* ((begin (save-match-data 80 (if (looking-back (concat "^\\(" ledger-iso-date-regexp "=\\|\\)" 81 ledger-incomplete-date-regexp) nil) 82 (match-end 1) 83 (save-excursion 84 (ledger-thing-at-point) ;; leave point at beginning of thing under point 85 (point))))) 86 (end (point)) 87 begins args) 88 ;; to support end of line metadata 89 (save-excursion 90 (when (search-backward ";" 91 (line-beginning-position) t) 92 (setq begin (match-beginning 0)))) 93 (save-excursion 94 (goto-char begin) 95 (when (< (point) end) 96 (skip-chars-forward " \t\n") 97 (setq begins (cons (point) begins)) 98 (setq args (cons (buffer-substring-no-properties 99 (car begins) end) 100 args))) 101 (cons (reverse args) (reverse begins))))) 102 103 104 (defun ledger-payees-in-buffer () 105 "Scan buffer and return list of all payees." 106 (let ((origin (point)) 107 payees-list) 108 (save-excursion 109 (goto-char (point-min)) 110 (while (re-search-forward ledger-payee-name-or-directive-regex nil t) 111 (unless (and (>= origin (match-beginning 0)) 112 (< origin (match-end 0))) 113 (push (or (match-string-no-properties 1) (match-string-no-properties 2)) 114 payees-list)))) 115 ;; to the list 116 (sort (delete-dups payees-list) #'string-lessp))) 117 118 (defun ledger-payees-list () 119 "Return a list of all known account names as strings. 120 Looks in `ledger-payees-file' if set, otherwise the current buffer." 121 (if ledger-payees-file 122 (let ((f ledger-payees-file)) 123 (with-temp-buffer 124 (insert-file-contents f) 125 (ledger-payees-in-buffer))) 126 (ledger-payees-in-buffer))) 127 128 (defun ledger-accounts-in-buffer () 129 "Return an alist of accounts in the current buffer. 130 The `car' of each element is the account name and the `cdr' is an 131 alist where the key is a subdirective such as \"assert\" and the 132 value (if any) is the associated data. In other words, if you've 133 declared an account like so: 134 135 account Assets:Checking 136 assert commodity == \"$\" 137 default 138 139 Then one of the elements this function returns will be 140 \(\"Assets:Checking\" 141 (\"default\") 142 (\"assert\" . \"commodity == \"$\"\"))" 143 (save-excursion 144 (goto-char (point-min)) 145 (let (account-list 146 (seen (make-hash-table :test #'equal :size 1))) 147 ;; First, consider accounts declared with "account" directives, which may or 148 ;; may not have associated data. The data is on the following lines up to a 149 ;; line not starting with whitespace. 150 (while (re-search-forward ledger-account-directive-regex nil t) 151 (let ((account (match-string-no-properties 1)) 152 (lines (buffer-substring-no-properties 153 (point) 154 (progn (ledger-navigate-next-xact-or-directive) 155 (point)))) 156 data) 157 (dolist (d (split-string lines "\n")) 158 (setq d (string-trim d)) 159 (unless (string= d "") 160 (if (string-match " " d) 161 (push (cons (substring d 0 (match-beginning 0)) 162 (substring d (match-end 0) nil)) 163 data) 164 (push (cons d nil) data)))) 165 (push (cons account data) account-list) 166 (puthash account t seen))) 167 ;; Next, gather all accounts declared in postings 168 (unless 169 ;; FIXME: People who have set `ledger-flymake-be-pedantic' to non-nil 170 ;; probably don't want accounts from postings, just those declared 171 ;; with directives. But the name is a little misleading. Should we 172 ;; make a ledger-mode-be-pedantic and use that instead? 173 (bound-and-true-p ledger-flymake-be-pedantic) 174 (ledger-xact-iterate-transactions 175 (lambda (_pos _date _state _payee) 176 (let ((end (save-excursion (ledger-navigate-end-of-xact)))) 177 (forward-line) 178 (while (re-search-forward ledger-account-any-status-regex end t) 179 (let ((account (match-string-no-properties 1))) 180 (unless (gethash account seen) 181 (puthash account t seen) 182 (push (cons account nil) account-list)))))))) 183 (sort account-list (lambda (a b) (string-lessp (car a) (car b))))))) 184 185 (defun ledger-accounts-list-in-buffer () 186 "Return a list of all known account names in the current buffer as strings. 187 Considers both accounts listed in postings and those declared 188 with \"account\" directives." 189 (let ((accounts (ledger-accounts-in-buffer))) 190 (when ledger-accounts-exclude-function 191 (setq accounts (cl-remove-if ledger-accounts-exclude-function accounts))) 192 (mapcar #'car accounts))) 193 194 (defun ledger-accounts-list () 195 "Return a list of all known account names as strings. 196 Looks in `ledger-accounts-file' if set, otherwise the current buffer." 197 (if ledger-accounts-file 198 (let ((f ledger-accounts-file)) 199 (with-temp-buffer 200 (insert-file-contents f) 201 (ledger-accounts-list-in-buffer))) 202 (ledger-accounts-list-in-buffer))) 203 204 (defun ledger-find-accounts-in-buffer () 205 (let ((account-tree (list t)) 206 (account-elements nil)) 207 (save-excursion 208 (goto-char (point-min)) 209 210 (dolist (account (ledger-accounts-list)) 211 (let ((root account-tree)) 212 (setq account-elements 213 (split-string 214 account ":")) 215 (while account-elements 216 (let ((xact (assoc (car account-elements) root))) 217 (if xact 218 (setq root (cdr xact)) 219 (setq xact (cons (car account-elements) (list t))) 220 (nconc root (list xact)) 221 (setq root (cdr xact)))) 222 (setq account-elements (cdr account-elements)))))) 223 account-tree)) 224 225 (defun ledger-accounts-tree () 226 "Return a tree of all accounts in the buffer." 227 (let* ((current (caar (ledger-parse-arguments))) 228 (elements (and current (split-string current ":"))) 229 (root (ledger-find-accounts-in-buffer)) 230 (prefix nil)) 231 (while (cdr elements) 232 (let ((xact (assoc (car elements) root))) 233 (if xact 234 (setq prefix (concat prefix (and prefix ":") 235 (car elements)) 236 root (cdr xact)) 237 (setq root nil elements nil))) 238 (setq elements (cdr elements))) 239 (setq root (delete (list (car elements) t) root)) 240 (and root 241 (sort 242 (mapcar (function 243 (lambda (x) 244 (let ((term (if prefix 245 (concat prefix ":" (car x)) 246 (car x)))) 247 (if (> (length (cdr x)) 1) 248 (concat term ":") 249 term)))) 250 (cdr root)) 251 'string-lessp)))) 252 253 (defun ledger-complete-date (month-string day-string) 254 "Complete a date." 255 (let* 256 ((now (current-time)) 257 (decoded (decode-time now)) 258 (this-month (nth 4 decoded)) 259 (this-year (nth 5 decoded)) 260 (last-month (if (> this-month 1) (1- this-month) 12)) 261 (last-year (1- this-year)) 262 (last-month-year (if (> this-month 1) this-year last-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 this-month) this-year) 267 (if month 268 (encode-time 0 0 0 day month last-year) 269 (encode-time 0 0 0 day last-month last-month-year))))) 270 (lambda (_string _predicate _all) 271 (concat (ledger-format-date 272 (cl-find-if (lambda (date) (not (time-less-p now date))) dates)) 273 (and (= (point) (line-end-position)) " "))))) 274 275 (defun ledger-complete-effective-date 276 (tx-year-string tx-month-string tx-day-string 277 month-string day-string) 278 "Complete an effective date." 279 (let* 280 ((tx-year (string-to-number tx-year-string)) 281 (tx-month (string-to-number tx-month-string)) 282 (tx-day (string-to-number tx-day-string)) 283 (tx-date (encode-time 0 0 0 tx-day tx-month tx-year)) 284 (next-month (if (< tx-month 12) (1+ tx-month) 1)) 285 (next-year (1+ tx-year)) 286 (next-month-year (if (< tx-month 12) tx-year next-year)) 287 (month (and month-string 288 (string-to-number month-string))) 289 (day (string-to-number day-string)) 290 (dates (list (encode-time 0 0 0 day (or month tx-month) tx-year) 291 (if month 292 (encode-time 0 0 0 day month next-year) 293 (encode-time 0 0 0 day next-month next-month-year))))) 294 (lambda (_string _predicate _all) 295 (concat (ledger-format-date 296 (cl-find-if (lambda (date) (not (time-less-p date tx-date))) dates)) 297 (and (= (point) (line-end-position)) " "))))) 298 299 (defun ledger-complete-at-point () 300 "Do appropriate completion for the thing at point." 301 (let ((end (point)) 302 start collection 303 realign-after 304 delete-suffix) 305 (cond (;; Date 306 (looking-back (concat "^" ledger-incomplete-date-regexp) (line-beginning-position)) 307 (setq collection (ledger-complete-date (match-string 1) (match-string 2)) 308 start (match-beginning 0) 309 delete-suffix (save-match-data 310 (when (looking-at (rx (one-or-more (or digit (any ?/ ?-))))) 311 (length (match-string 0)))))) 312 (;; Effective dates 313 (looking-back (concat "^" ledger-iso-date-regexp "=" ledger-incomplete-date-regexp) 314 (line-beginning-position)) 315 (setq start (line-beginning-position)) 316 (setq collection (ledger-complete-effective-date 317 (match-string 2) (match-string 3) (match-string 4) 318 (match-string 5) (match-string 6)))) 319 (;; Payees 320 (eq (save-excursion (ledger-thing-at-point)) 'transaction) 321 (setq start (save-excursion (backward-word) (point))) 322 (setq collection #'ledger-payees-list)) 323 (;; Accounts 324 (save-excursion 325 (back-to-indentation) 326 (skip-chars-forward "([") ;; for virtual accounts 327 (setq start (point))) 328 (setq delete-suffix (save-excursion 329 (when (search-forward-regexp (rx (or eol (or ?\t (repeat 2 space)))) (line-end-position) t) 330 (- (match-beginning 0) end))) 331 realign-after t 332 collection (if ledger-complete-in-steps 333 #'ledger-accounts-tree 334 #'ledger-accounts-list)))) 335 (when collection 336 (let ((prefix (buffer-substring-no-properties start end))) 337 (list start end 338 (if (functionp collection) 339 (completion-table-with-cache 340 (lambda (_) 341 (cl-remove-if (apply-partially 'string= prefix) (funcall 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 'ignore))))) 349 350 (defun ledger-trim-trailing-whitespace (str) 351 (replace-regexp-in-string "[ \t]*$" "" str)) 352 353 (defun ledger-fully-complete-xact () 354 "Completes a transaction if there is another matching payee in the buffer. 355 356 Interactively, if point is after a payee, complete the 357 transaction with the details from the last transaction to that 358 payee." 359 (interactive) 360 (let* ((name (ledger-trim-trailing-whitespace (caar (ledger-parse-arguments)))) 361 (rest-of-name name) 362 xacts) 363 (save-excursion 364 (when (eq 'transaction (ledger-thing-at-point)) 365 (delete-region (point) (+ (length name) (point))) 366 ;; Search backward for a matching payee 367 (when (re-search-backward 368 (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.*" 369 (regexp-quote name) ".*\\)" ) nil t) 370 (setq rest-of-name (match-string 3)) 371 ;; Start copying the postings 372 (forward-line) 373 (setq xacts (buffer-substring-no-properties (point) (ledger-navigate-end-of-xact)))))) 374 ;; Insert rest-of-name and the postings 375 (save-excursion 376 (insert rest-of-name ?\n) 377 (insert xacts) 378 (unless (looking-at-p "\n\n") 379 (insert "\n"))) 380 (forward-line) 381 (goto-char (line-end-position)) 382 (when (re-search-backward "\\(\t\\| [ \t]\\)" nil t) 383 (goto-char (match-end 0))))) 384 385 (provide 'ledger-complete) 386 387 ;;; ledger-complete.el ends here