ledger-mode.el (15078B)
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 (defun ledger-remove-effective-date () 164 "Remove the effective date from a transaction or posting." 165 (interactive) 166 (let ((context (car (ledger-context-at-point)))) 167 (save-excursion 168 (save-restriction 169 (narrow-to-region (line-beginning-position) (line-end-position)) 170 (beginning-of-line) 171 (cond ((eq 'xact context) 172 (re-search-forward ledger-iso-date-regexp) 173 (when (= (char-after) ?=) 174 (let ((eq-pos (point))) 175 (delete-region 176 eq-pos 177 (re-search-forward ledger-iso-date-regexp))))) 178 ((eq 'acct-transaction context) 179 ;; Match "; [=date]" & delete string 180 (when (re-search-forward 181 (concat ledger-comment-regex 182 "\\[=" ledger-iso-date-regexp "\\]") 183 nil 'noerr) 184 (replace-match "")))))))) 185 186 (defun ledger-insert-effective-date (&optional date) 187 "Insert effective date `DATE' to the transaction or posting. 188 189 If `DATE' is nil, prompt the user a date. 190 191 Replace the current effective date if there's one in the same 192 line. 193 194 With a prefix argument, remove the effective date." 195 (interactive) 196 (if (and (listp current-prefix-arg) 197 (= 4 (prefix-numeric-value current-prefix-arg))) 198 (ledger-remove-effective-date) 199 (let* ((context (car (ledger-context-at-point))) 200 (date-string (or date (ledger-read-date "Effective date: ")))) 201 (save-restriction 202 (narrow-to-region (line-beginning-position) (line-end-position)) 203 (cond 204 ((eq 'xact context) 205 (beginning-of-line) 206 (re-search-forward ledger-iso-date-regexp) 207 (when (= (char-after) ?=) 208 (ledger-remove-effective-date)) 209 (insert "=" date-string)) 210 ((eq 'acct-transaction context) 211 (end-of-line) 212 (ledger-remove-effective-date) 213 (insert " ; [=" date-string "]"))))))) 214 215 (defun ledger-mode-remove-extra-lines () 216 "Get rid of multiple empty lines." 217 (goto-char (point-min)) 218 (while (re-search-forward "\n\n\\(\n\\)+" nil t) 219 (replace-match "\n\n"))) 220 221 (defun ledger-mode-clean-buffer () 222 "Indent, remove multiple line feeds and sort the buffer." 223 (interactive) 224 (let ((start (point-min-marker)) 225 (end (point-max-marker)) 226 (distance-in-xact (- (point) (ledger-navigate-beginning-of-xact)))) 227 (let ((target (buffer-substring (line-beginning-position) (line-end-position)))) 228 (goto-char start) 229 (untabify start end) 230 (ledger-sort-buffer) 231 (ledger-post-align-postings start end) 232 (ledger-mode-remove-extra-lines) 233 (goto-char start) 234 (search-forward target) 235 (beginning-of-line) 236 (forward-char distance-in-xact)))) 237 238 (defun ledger-rename-account (old new &optional toplevel-only) 239 "Rename account with name OLD to name NEW. 240 241 Affects account names mentioned in postings as well as declared 242 with the \"account\" directive. 243 244 By default, child accounts of OLD are also renamed to 245 corresponding child accounts of NEW. With \\[universal-argument] 246 prefix, child accounts are not renamed. When called from Lisp, 247 TOPLEVEL-ONLY has the same meaning." 248 (interactive "sOld name: \nsNew name: \nP") 249 (save-excursion 250 (goto-char (point-min)) 251 (while (re-search-forward ledger-account-name-or-directive-regex nil t) 252 (let ((account (match-string 1))) 253 (cond 254 ((string-equal account old) 255 (replace-match new 'fixedcase 'literal nil 1)) 256 ((and (not toplevel-only) 257 (string-prefix-p (concat old ":") account)) 258 (replace-match 259 (concat new (substring account (length old))) 260 'fixedcase 'literal nil 1)))))) 261 (when ledger-post-auto-align 262 (ledger-post-align-postings (point-min) (point-max)))) 263 264 (defvar ledger-mode-syntax-table 265 (let ((table (make-syntax-table text-mode-syntax-table))) 266 (modify-syntax-entry ?\; "<" table) 267 (modify-syntax-entry ?\n ">" table) 268 table) 269 "Syntax table in use in `ledger-mode' buffers.") 270 271 (defvar ledger-mode-map 272 (let ((map (make-sparse-keymap))) 273 (define-key map (kbd "C-c C-a") #'ledger-add-transaction) 274 (define-key map (kbd "C-c C-b") #'ledger-post-edit-amount) 275 (define-key map (kbd "C-c C-c") #'ledger-toggle-current) 276 (define-key map (kbd "C-c C-d") #'ledger-delete-current-transaction) 277 (define-key map (kbd "C-c C-e") #'ledger-toggle-current-transaction) 278 (define-key map (kbd "C-c C-f") #'ledger-occur) 279 (define-key map (kbd "C-c C-k") #'ledger-copy-transaction-at-point) 280 (define-key map (kbd "C-c C-r") #'ledger-reconcile) 281 (define-key map (kbd "C-c C-s") #'ledger-sort-region) 282 (define-key map (kbd "C-c C-t") #'ledger-insert-effective-date) 283 (define-key map (kbd "C-c C-u") #'ledger-schedule-upcoming) 284 (define-key map (kbd "C-c C-p") #'ledger-display-balance-at-point) 285 (define-key map (kbd "C-c C-l") #'ledger-display-ledger-stats) 286 (define-key map (kbd "C-c C-q") #'ledger-post-align-xact) 287 288 (define-key map (kbd "C-TAB") #'ledger-post-align-xact) 289 (define-key map (kbd "C-c TAB") #'ledger-fully-complete-xact) 290 (define-key map (kbd "C-c C-i") #'ledger-fully-complete-xact) 291 292 (define-key map (kbd "C-c C-o C-a") #'ledger-report-redo) 293 (define-key map (kbd "C-c C-o C-e") #'ledger-report-edit-report) 294 (define-key map (kbd "C-c C-o C-g") #'ledger-report-goto) 295 (define-key map (kbd "C-c C-o C-k") #'ledger-report-quit) 296 (define-key map (kbd "C-c C-o C-r") #'ledger-report) 297 (define-key map (kbd "C-c C-o C-s") #'ledger-report-save) 298 299 (define-key map (kbd "M-p") #'ledger-navigate-prev-xact-or-directive) 300 (define-key map (kbd "M-n") #'ledger-navigate-next-xact-or-directive) 301 (define-key map (kbd "M-q") #'ledger-post-align-dwim) 302 303 ;; Reset the `text-mode' override of this standard binding 304 (define-key map (kbd "C-M-i") 'completion-at-point) 305 map) 306 "Keymap for `ledger-mode'.") 307 308 (easy-menu-define ledger-mode-menu ledger-mode-map 309 "Ledger menu" 310 '("Ledger" 311 ["Narrow to REGEX" ledger-occur] 312 ["Show all transactions" ledger-occur-mode ledger-occur-mode] 313 ["Ledger Statistics" ledger-display-ledger-stats ledger-works] 314 "---" 315 ["Show upcoming transactions" ledger-schedule-upcoming] 316 ["Add Transaction (ledger xact)" ledger-add-transaction ledger-works] 317 ["Complete Transaction" ledger-fully-complete-xact] 318 ["Delete Transaction" ledger-delete-current-transaction] 319 "---" 320 ["Calc on Amount" ledger-post-edit-amount] 321 "---" 322 ["Check Balance" ledger-display-balance-at-point ledger-works] 323 ["Reconcile Account" ledger-reconcile ledger-works] 324 "---" 325 ["Toggle Current Transaction" ledger-toggle-current-transaction] 326 ["Toggle Current Posting" ledger-toggle-current] 327 ["Copy Trans at Point" ledger-copy-transaction-at-point] 328 "---" 329 ["Clean-up Buffer" ledger-mode-clean-buffer] 330 ["Check Buffer" ledger-check-buffer ledger-works] 331 ["Align Region" ledger-post-align-postings mark-active] 332 ["Align Xact" ledger-post-align-xact] 333 ["Sort Region" ledger-sort-region mark-active] 334 ["Sort Buffer" ledger-sort-buffer] 335 ["Mark Sort Beginning" ledger-sort-insert-start-mark] 336 ["Mark Sort End" ledger-sort-insert-end-mark] 337 ["Set effective date" ledger-insert-effective-date] 338 "---" 339 ["Customize Ledger Mode" (lambda () (interactive) (customize-group 'ledger))] 340 "---" 341 ["Run Report" ledger-report ledger-works] 342 ["Goto Report" ledger-report-goto ledger-works] 343 ["Re-run Report" ledger-report-redo ledger-works] 344 ["Save Report" ledger-report-save ledger-works] 345 ["Edit Report" ledger-report-edit-report ledger-works] 346 ["Quit Report" ledger-report-quit ledger-works])) 347 348 ;;;###autoload 349 (define-derived-mode ledger-mode text-mode "Ledger" 350 "A mode for editing ledger data files." 351 (ledger-check-version) 352 (setq font-lock-defaults 353 '(ledger-font-lock-keywords t nil nil nil)) 354 (add-hook 'font-lock-extend-region-functions 'ledger-fontify-extend-region) 355 (add-hook 'completion-at-point-functions #'ledger-complete-at-point nil t) 356 (add-hook 'after-save-hook 'ledger-report-redo nil t) 357 358 (add-hook 'post-command-hook 'ledger-highlight-xact-under-point nil t) 359 (add-hook 'before-revert-hook 'ledger-highlight--before-revert nil t) 360 (add-hook 'after-revert-hook 'ledger-highlight-xact-under-point nil t) 361 362 (ledger-init-load-init-file) 363 (setq-local comment-start ";") 364 (setq-local indent-line-function #'ledger-indent-line) 365 (setq-local indent-region-function 'ledger-post-align-postings) 366 (setq-local beginning-of-defun-function #'ledger-navigate-beginning-of-xact) 367 (setq-local end-of-defun-function #'ledger-navigate-end-of-xact)) 368 369 ;;;###autoload 370 (add-to-list 'auto-mode-alist '("\\.ledger\\'" . ledger-mode)) 371 372 (provide 'ledger-mode) 373 374 ;;; ledger-mode.el ends here