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