ledger-mode.el (18482B)
1 ;;; ledger-mode.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 ;; Package-Version: 20241007.1655 8 ;; Package-Revision: 9be25db0566d 9 ;; Package-Requires: ((emacs "25.1")) 10 11 ;; This is free software; you can redistribute it and/or modify it under 12 ;; the terms of the GNU General Public License as published by the Free 13 ;; Software Foundation; either version 2, or (at your option) any later 14 ;; version. 15 ;; 16 ;; This is distributed in the hope that it will be useful, but WITHOUT 17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or 18 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 19 ;; for more details. 20 ;; 21 ;; You should have received a copy of the GNU General Public License 22 ;; along with GNU Emacs; see the file COPYING. If not, write to the 23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, 24 ;; MA 02110-1301 USA. 25 26 ;;; Commentary: 27 ;; This Emacs library provides a major mode for editing files in the format used 28 ;; by the `ledger' command-line accounting system. 29 30 ;; It also provides automated support for some `ledger' workflows, such as 31 ;; reconciling transactions, or running certain reports. 32 33 ;;; Code: 34 35 (require 'ledger-regex) 36 (require 'org) 37 (require 'ledger-commodities) 38 (require 'ledger-complete) 39 (require 'ledger-context) 40 (require 'ledger-exec) 41 (require 'ledger-fonts) 42 (require 'ledger-fontify) 43 (require 'ledger-init) 44 (require 'ledger-navigate) 45 (require 'ledger-occur) 46 (require 'ledger-post) 47 (require 'ledger-reconcile) 48 (require 'ledger-report) 49 (require 'ledger-sort) 50 (require 'ledger-state) 51 (require 'ledger-test) 52 (require 'ledger-texi) 53 (require 'ledger-xact) 54 (require 'ledger-schedule) 55 (require 'ledger-check) 56 57 (declare-function custom-group-members "cus-edit" (symbol groups-only)) 58 59 ;;; Code: 60 61 (defgroup ledger nil 62 "Interface to the Ledger command-line accounting program." 63 :group 'data) 64 65 (defconst ledger-version "3.0" 66 "The version of ledger.el currently loaded.") 67 68 (defconst ledger-mode-version "4.0.0") 69 70 (defun ledger-mode-dump-variable (var) 71 "Format VAR for dump to buffer." 72 (if var 73 (insert (format " %s: %S\n" (symbol-name var) (eval var))))) 74 75 (defun ledger-mode-dump-group (group) 76 "Dump GROUP customizations to current buffer." 77 (require 'cus-edit) 78 (let ((members (custom-group-members group nil))) 79 (dolist (member members) 80 (cond ((eq (cadr member) 'custom-group) 81 (insert (format "Group %s:\n" (symbol-name (car member)))) 82 (ledger-mode-dump-group (car member))) 83 ((eq (cadr member) 'custom-variable) 84 (ledger-mode-dump-variable (car member))))))) 85 86 (defun ledger-mode-dump-configuration () 87 "Dump all customizations." 88 (interactive) 89 (find-file "ledger-mode-dump") 90 (ledger-mode-dump-group 'ledger)) 91 92 (defun ledger-read-account-with-prompt (prompt) 93 "Read an account from the minibuffer with PROMPT." 94 (let* ((context (ledger-context-at-point)) 95 (account (ledger-context-field-value context 'account))) 96 (ledger-completing-read-with-default prompt 97 (when account 98 (regexp-quote account)) 99 (ledger-accounts-list)))) 100 101 (defun ledger-read-payee-with-prompt (prompt) 102 "Read a payee from the minibuffer with PROMPT." 103 (ledger-completing-read-with-default prompt 104 (when-let ((payee (ledger-xact-payee))) 105 (regexp-quote payee)) 106 (ledger-payees-list))) 107 108 (defun ledger-read-date (prompt) 109 "Return user-supplied date after `PROMPT', defaults to today. 110 This uses `org-read-date', which see." 111 (ledger-format-date (let ((org-read-date-prefer-future nil)) 112 (org-read-date nil t nil prompt)))) 113 114 (defun ledger-get-minibuffer-prompt (prompt default) 115 "Return a minibuffer prompt string composing PROMPT and DEFAULT." 116 (concat prompt 117 (if default 118 (concat " (" default "): ") 119 ": "))) 120 121 (defun ledger-completing-read-with-default (prompt default collection) 122 "Return a user-supplied string after PROMPT. 123 Use the given DEFAULT, while providing completions from COLLECTION." 124 (completing-read (ledger-get-minibuffer-prompt prompt default) 125 collection nil nil nil 'ledger-minibuffer-history default)) 126 127 (defun ledger-read-string-with-default (prompt default) 128 "Return user supplied string after PROMPT, or DEFAULT." 129 (read-string (ledger-get-minibuffer-prompt prompt default) 130 nil 'ledger-minibuffer-history default)) 131 132 (defun ledger-display-balance-at-point (&optional arg) 133 "Display the cleared-or-pending balance. 134 And calculate the target-delta of the account being reconciled. 135 136 With ARG (\\[universal-argument]) ask for the target commodity and convert 137 the balance into that." 138 (interactive "P") 139 (let* ((account (ledger-read-account-with-prompt "Account balance to show")) 140 (target-commodity (when arg (ledger-read-commodity-with-prompt "Target commodity: "))) 141 (buffer (find-file-noselect (ledger-master-file))) 142 (balance (with-temp-buffer 143 (apply 'ledger-exec-ledger buffer (current-buffer) "cleared" account 144 (when target-commodity (list "-X" target-commodity))) 145 (if (> (buffer-size) 0) 146 (buffer-substring-no-properties (point-min) (1- (point-max))) 147 (concat account " is empty."))))) 148 (when balance 149 (display-message-or-buffer balance)))) 150 151 (defun ledger-display-ledger-stats () 152 "Display some summary statistics about the current ledger file." 153 (interactive) 154 (let* ((buffer (find-file-noselect (ledger-master-file))) 155 (balance (with-temp-buffer 156 (ledger-exec-ledger buffer (current-buffer) "stats") 157 (buffer-substring-no-properties (point-min) (1- (point-max)))))) 158 (when balance 159 (message balance)))) 160 161 (defvar ledger-mode-abbrev-table) 162 163 (defvar ledger-date-string-today (ledger-format-date)) 164 165 166 167 ;;; Editing commands 168 169 (defun ledger-remove-effective-date () 170 "Remove the effective date from a transaction or posting." 171 (interactive) 172 (let ((context (car (ledger-context-at-point)))) 173 (save-excursion 174 (save-restriction 175 (narrow-to-region (line-beginning-position) (line-end-position)) 176 (beginning-of-line) 177 (cond ((eq 'xact context) 178 (re-search-forward ledger-iso-date-regexp) 179 (when (= (char-after) ?=) 180 (let ((eq-pos (point))) 181 (delete-region 182 eq-pos 183 (re-search-forward ledger-iso-date-regexp))))) 184 ((eq 'acct-transaction context) 185 ;; Match "; [=date]" & delete string 186 (when (re-search-forward 187 (concat ledger-comment-regex 188 "\\[=" ledger-iso-date-regexp "\\]") 189 nil 'noerr) 190 (replace-match "")))))))) 191 192 (defun ledger-insert-effective-date (&optional date) 193 "Insert effective date `DATE' to the transaction or posting. 194 195 If `DATE' is nil, prompt the user a date. 196 197 Replace the current effective date if there's one in the same 198 line. 199 200 With a prefix argument, remove the effective date." 201 (interactive) 202 (if (and (listp current-prefix-arg) 203 (= 4 (prefix-numeric-value current-prefix-arg))) 204 (ledger-remove-effective-date) 205 (let* ((context (car (ledger-context-at-point))) 206 (date-string (or date (ledger-read-date "Effective date: ")))) 207 (save-restriction 208 (narrow-to-region (line-beginning-position) (line-end-position)) 209 (cond 210 ((eq 'xact context) 211 (beginning-of-line) 212 (re-search-forward ledger-iso-date-regexp) 213 (when (= (char-after) ?=) 214 (ledger-remove-effective-date)) 215 (insert "=" date-string)) 216 ((eq 'acct-transaction context) 217 (end-of-line) 218 (ledger-remove-effective-date) 219 (insert " ; [=" date-string "]"))))))) 220 221 (defun ledger-mode-remove-extra-lines () 222 "Get rid of multiple empty lines." 223 (goto-char (point-min)) 224 (while (re-search-forward "\n\n\\(\n\\)+" nil t) 225 (replace-match "\n\n"))) 226 227 (defun ledger-mode-clean-buffer () 228 "Indent, remove multiple line feeds and sort the buffer." 229 (interactive) 230 (let ((start (point-min-marker)) 231 (end (point-max-marker)) 232 (distance-in-xact (- (point) (ledger-navigate-beginning-of-xact)))) 233 (let ((target (buffer-substring (line-beginning-position) (line-end-position)))) 234 (goto-char start) 235 (untabify start end) 236 (ledger-sort-buffer) 237 (ledger-post-align-postings start end) 238 (ledger-mode-remove-extra-lines) 239 (goto-char start) 240 (search-forward target) 241 (beginning-of-line) 242 (forward-char distance-in-xact)))) 243 244 (defun ledger-rename-account (old new &optional toplevel-only) 245 "Rename account with name OLD to name NEW. 246 247 Affects account names mentioned in postings as well as declared 248 with the \"account\" directive. 249 250 By default, child accounts of OLD are also renamed to 251 corresponding child accounts of NEW. With \\[universal-argument] 252 prefix, child accounts are not renamed. When called from Lisp, 253 TOPLEVEL-ONLY has the same meaning." 254 (interactive 255 (let* ((old-name 256 (ledger-read-account-with-prompt "Old name: ")) 257 (new-name 258 (ledger-read-string-with-default "New name: " old-name))) 259 (list old-name new-name current-prefix-arg))) 260 (save-excursion 261 (goto-char (point-min)) 262 (while (re-search-forward ledger-account-name-or-directive-regex nil t) 263 (let ((account (match-string 1))) 264 (cond 265 ((string-equal account old) 266 (replace-match new 'fixedcase 'literal nil 1)) 267 ((and (not toplevel-only) 268 (string-prefix-p (concat old ":") account)) 269 (replace-match 270 (concat new (substring account (length old))) 271 'fixedcase 'literal nil 1)))))) 272 (when ledger-post-auto-align 273 (ledger-post-align-postings (point-min) (point-max)))) 274 275 276 277 ;;; Commands for changing dates 278 279 ;; These functions are adapted from the implementation of `org-timestamp-change'. 280 281 (defun ledger--in-regexp (regexp) 282 "Return (BEG . END) if point is inside a match of REGEXP, or nil. 283 284 Only check the current line for occurrences of REGEXP." 285 (catch :exit 286 (let ((pos (point)) 287 (eol (line-end-position))) 288 (save-excursion 289 (beginning-of-line) 290 (while (and (re-search-forward regexp eol t) 291 (<= (match-beginning 0) pos)) 292 (let ((end (match-end 0))) 293 (when (>= end pos) 294 (throw :exit (cons (match-beginning 0) (match-end 0)))))))))) 295 296 (defsubst ledger--pos-in-match-range (pos n) 297 "Return non-nil if POS is inside the range of group N in the match data." 298 (and (match-beginning n) 299 (<= (match-beginning n) pos) 300 (>= (match-end n) pos))) 301 302 (defun ledger--at-date-p () 303 "Return non-nil if point is inside a date. 304 305 Specifically, return `year', `month', or `day', depending on 306 which part of the date string point is in." 307 (let ((pos (point)) 308 (boundaries (ledger--in-regexp ledger-iso-date-regexp))) 309 (cond ((null boundaries) nil) 310 ((ledger--pos-in-match-range pos 2) 'year) 311 ((ledger--pos-in-match-range pos 3) 'month) 312 ((ledger--pos-in-match-range pos 4) 'day)))) 313 314 (defun ledger--date-change (n) 315 "Change the date field at point by N (can be negative)." 316 (let ((date-cat (ledger--at-date-p)) 317 (origin-pos (point)) 318 date-separator 319 date-str time-old time-new) 320 (unless date-cat (user-error "Not at a date")) 321 (setq date-str (match-string 0)) 322 (setq date-separator 323 (string (aref date-str 4))) 324 (save-match-data 325 (setq time-old (decode-time (ledger-parse-iso-date date-str))) 326 (setq time-new 327 ;; Do not pass DST or ZONE arguments here; it should be 328 ;; automatically inferred from the other arguments, since the 329 ;; appropriate DST value may differ from `time-old'. 330 (encode-time 331 0 ; second 332 0 ; minute 333 0 ; hour 334 (+ (if (eq date-cat 'day) n 0) (nth 3 time-old)) 335 (+ (if (eq date-cat 'month) n 0) (nth 4 time-old)) 336 (+ (if (eq date-cat 'year) n 0) (nth 5 time-old))))) 337 (replace-match (format-time-string (concat "%Y" date-separator "%m" date-separator "%d") 338 time-new) 339 'fixedcase 340 'literal) 341 (goto-char origin-pos))) 342 343 (defun ledger-date-up (&optional arg) 344 "Increment the date field at point by 1. 345 With prefix ARG, increment by that many instead." 346 (interactive "p") 347 (ledger--date-change arg)) 348 349 (defun ledger-date-down (&optional arg) 350 "Decrement the date field at point by 1. 351 With prefix ARG, decrement by that many instead." 352 (interactive "p") 353 (ledger--date-change (- arg))) 354 355 356 357 ;;; Major mode definition 358 359 (defvar ledger-mode-syntax-table 360 (let ((table (make-syntax-table text-mode-syntax-table))) 361 (modify-syntax-entry ?\; "<" table) 362 (modify-syntax-entry ?\n ">" table) 363 table) 364 "Syntax table in use in `ledger-mode' buffers.") 365 366 (defvar ledger-mode-map 367 (let ((map (make-sparse-keymap))) 368 (define-key map (kbd "C-c C-a") #'ledger-add-transaction) 369 (define-key map (kbd "C-c C-b") #'ledger-post-edit-amount) 370 (define-key map (kbd "C-c C-c") #'ledger-toggle-current) 371 (define-key map (kbd "C-c C-d") #'ledger-delete-current-transaction) 372 (define-key map (kbd "C-c C-e") #'ledger-toggle-current-transaction) 373 (define-key map (kbd "C-c C-f") #'ledger-occur) 374 (define-key map (kbd "C-c C-k") #'ledger-copy-transaction-at-point) 375 (define-key map (kbd "C-c C-r") #'ledger-reconcile) 376 (define-key map (kbd "C-c C-s") #'ledger-sort-region) 377 (define-key map (kbd "C-c C-t") #'ledger-insert-effective-date) 378 (define-key map (kbd "C-c C-u") #'ledger-schedule-upcoming) 379 (define-key map (kbd "C-c C-p") #'ledger-display-balance-at-point) 380 (define-key map (kbd "C-c C-l") #'ledger-display-ledger-stats) 381 (define-key map (kbd "C-c C-q") #'ledger-post-align-xact) 382 383 (define-key map (kbd "C-TAB") #'ledger-post-align-xact) 384 (define-key map (kbd "C-c TAB") #'ledger-fully-complete-xact) 385 (define-key map (kbd "C-c C-i") #'ledger-fully-complete-xact) 386 387 (define-key map (kbd "C-c C-o C-a") #'ledger-report-redo) 388 (define-key map (kbd "C-c C-o C-e") #'ledger-report-edit-report) 389 (define-key map (kbd "C-c C-o C-g") #'ledger-report-goto) 390 (define-key map (kbd "C-c C-o C-k") #'ledger-report-quit) 391 (define-key map (kbd "C-c C-o C-r") #'ledger-report) 392 (define-key map (kbd "C-c C-o C-s") #'ledger-report-save) 393 394 (define-key map (kbd "M-p") #'ledger-navigate-prev-xact-or-directive) 395 (define-key map (kbd "M-n") #'ledger-navigate-next-xact-or-directive) 396 (define-key map (kbd "M-q") #'ledger-post-align-dwim) 397 398 (define-key map (kbd "S-<up>") #'ledger-date-up) 399 (define-key map (kbd "S-<down>") #'ledger-date-down) 400 401 ;; Reset the `text-mode' override of this standard binding 402 (define-key map (kbd "C-M-i") 'completion-at-point) 403 map) 404 "Keymap for `ledger-mode'.") 405 406 (easy-menu-define ledger-mode-menu ledger-mode-map 407 "Ledger menu" 408 '("Ledger" 409 ["Narrow to REGEX" ledger-occur] 410 ["Show all transactions" ledger-occur-mode ledger-occur-mode] 411 ["Ledger Statistics" ledger-display-ledger-stats ledger-works] 412 "---" 413 ["Show upcoming transactions" ledger-schedule-upcoming] 414 ["Add Transaction (ledger xact)" ledger-add-transaction ledger-works] 415 ["Complete Transaction" ledger-fully-complete-xact] 416 ["Delete Transaction" ledger-delete-current-transaction] 417 "---" 418 ["Calc on Amount" ledger-post-edit-amount] 419 "---" 420 ["Check Balance" ledger-display-balance-at-point ledger-works] 421 ["Reconcile Account" ledger-reconcile ledger-works] 422 "---" 423 ["Toggle Current Transaction" ledger-toggle-current-transaction] 424 ["Toggle Current Posting" ledger-toggle-current] 425 ["Copy Trans at Point" ledger-copy-transaction-at-point] 426 "---" 427 ["Clean-up Buffer" ledger-mode-clean-buffer] 428 ["Check Buffer" ledger-check-buffer ledger-works] 429 ["Align Region" ledger-post-align-postings mark-active] 430 ["Align Xact" ledger-post-align-xact] 431 ["Sort Region" ledger-sort-region mark-active] 432 ["Sort Buffer" ledger-sort-buffer] 433 ["Mark Sort Beginning" ledger-sort-insert-start-mark] 434 ["Mark Sort End" ledger-sort-insert-end-mark] 435 ["Set effective date" ledger-insert-effective-date] 436 "---" 437 ["Customize Ledger Mode" (lambda () (interactive) (customize-group 'ledger))] 438 "---" 439 ["Run Report" ledger-report ledger-works] 440 ["Goto Report" ledger-report-goto ledger-works] 441 ["Re-run Report" ledger-report-redo ledger-works] 442 ["Save Report" ledger-report-save ledger-works] 443 ["Edit Report" ledger-report-edit-report ledger-works] 444 ["Quit Report" ledger-report-quit ledger-works])) 445 446 ;;;###autoload 447 (define-derived-mode ledger-mode text-mode "Ledger" 448 "A mode for editing ledger data files." 449 (ledger-check-version) 450 (setq font-lock-defaults 451 '(ledger-font-lock-keywords t nil nil nil)) 452 (add-hook 'font-lock-extend-region-functions 'ledger-fontify-extend-region) 453 (add-hook 'completion-at-point-functions #'ledger-complete-at-point nil t) 454 (add-hook 'after-save-hook 'ledger-report-redo nil t) 455 456 (add-hook 'post-command-hook 'ledger-highlight-xact-under-point nil t) 457 (add-hook 'before-revert-hook 'ledger-highlight--before-revert nil t) 458 (add-hook 'after-revert-hook 'ledger-highlight-xact-under-point nil t) 459 460 (ledger-init-load-init-file) 461 (setq-local comment-start ";") 462 (setq-local indent-line-function #'ledger-indent-line) 463 (setq-local indent-region-function 'ledger-post-align-postings) 464 (setq-local beginning-of-defun-function #'ledger-navigate-beginning-of-xact) 465 (setq-local end-of-defun-function #'ledger-navigate-end-of-xact)) 466 467 ;;;###autoload 468 (add-to-list 'auto-mode-alist '("\\.ledger\\'" . ledger-mode)) 469 470 (provide 'ledger-mode) 471 472 ;;; ledger-mode.el ends here