ledger-xact.el (9253B)
1 ;;; ledger-xact.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 23 ;;; Commentary: 24 ;; Utilities for running ledger synchronously. 25 26 ;;; Code: 27 28 (require 'eshell) 29 (require 'ledger-regex) 30 (require 'ledger-navigate) 31 (require 'ledger-exec) 32 (require 'ledger-post) 33 (declare-function ledger-read-date "ledger-mode" (prompt)) 34 35 ;; TODO: This file depends on code in ledger-mode.el, which depends on this. 36 37 (defcustom ledger-highlight-xact-under-point t 38 "If t highlight xact under point." 39 :type 'boolean 40 :group 'ledger) 41 42 (defcustom ledger-add-transaction-prompt-for-text t 43 "When non-nil, use ledger xact to format transaction. 44 When nil, `ledger-add-transaction' will not prompt twice." 45 :type 'boolean 46 :package-version '(ledger-mode . "4.0.1") 47 :group 'ledger) 48 49 (defvar-local ledger-xact-highlight-overlay (list)) 50 51 (defun ledger-highlight-make-overlay () 52 (let ((ovl (make-overlay 1 1))) 53 (overlay-put ovl 'font-lock-face 'ledger-font-xact-highlight-face) 54 (overlay-put ovl 'priority '(nil . 99)) 55 ovl)) 56 57 (defun ledger-highlight-xact-under-point () 58 "Move the highlight overlay to the current transaction." 59 (when ledger-highlight-xact-under-point 60 (unless ledger-xact-highlight-overlay 61 (setq ledger-xact-highlight-overlay (ledger-highlight-make-overlay))) 62 (let ((exts (ledger-navigate-find-element-extents (point)))) 63 (let ((b (car exts)) 64 (e (cadr exts)) 65 (p (point))) 66 (if (and (> (- e b) 1) ; not an empty line 67 (<= p e) (>= p b) ; point is within the boundaries 68 (not (region-active-p))) ; no active region 69 (move-overlay ledger-xact-highlight-overlay b (+ 1 e)) 70 (move-overlay ledger-xact-highlight-overlay 1 1)))))) 71 72 (defun ledger-highlight--before-revert () 73 "Clean up highlighting overlay before reverting buffer." 74 (when ledger-xact-highlight-overlay 75 (delete-overlay ledger-xact-highlight-overlay))) 76 77 (defun ledger-xact-context () 78 "Return the context of the transaction containing point or nil." 79 (let ((i 0)) 80 (while (eq (ledger-context-line-type (ledger-context-other-line i)) 'acct-transaction) 81 (setq i (- i 1))) 82 (let ((context-info (ledger-context-other-line i))) 83 (when (eq (ledger-context-line-type context-info) 'xact) 84 context-info)))) 85 86 (defun ledger-xact-payee () 87 "Return the payee of the transaction containing point or nil." 88 (when-let ((xact-context (ledger-xact-context))) 89 (ledger-context-field-value xact-context 'payee))) 90 91 (defun ledger-xact-date () 92 "Return the date of the transaction containing point or nil." 93 (when-let ((xact-context (ledger-xact-context))) 94 (ledger-context-field-value xact-context 'date))) 95 96 (defun ledger-xact-find-slot (moment) 97 "Find the right place in the buffer for a transaction at MOMENT. 98 MOMENT is an encoded date" 99 (let (last-xact-start) 100 (catch 'found 101 (ledger-xact-iterate-transactions 102 (lambda (start date _mark _desc) 103 (setq last-xact-start start) 104 (when (time-less-p moment date) 105 (throw 'found t))))) 106 ;; If we are inserting at the end of the buffer, insert an extra newline 107 (when (and (eobp) last-xact-start) 108 (let ((end (cadr (ledger-navigate-find-xact-extents last-xact-start)))) 109 (goto-char end) 110 (insert "\n") 111 (forward-line))))) 112 113 (defun ledger-xact-iterate-transactions (callback) 114 "Iterate through each transaction call CALLBACK for each." 115 (goto-char (point-min)) 116 (let* ((now (current-time)) 117 (current-year (nth 5 (decode-time now)))) 118 (while (not (eobp)) 119 (when (looking-at ledger-iterate-regexp) 120 (if-let ((year (match-string 1))) 121 (setq current-year (string-to-number year)) ;a Y directive was found 122 (let ((start (match-beginning 0)) 123 (year (match-string (+ ledger-regex-iterate-group-actual-date 1))) 124 (month (string-to-number (match-string (+ ledger-regex-iterate-group-actual-date 2)))) 125 (day (string-to-number (match-string (+ ledger-regex-iterate-group-actual-date 3)))) 126 (state (match-string ledger-regex-iterate-group-state)) 127 (payee (match-string ledger-regex-iterate-group-payee))) 128 (if (and year (> (length year) 0)) 129 (setq year (string-to-number year))) 130 (funcall callback start 131 (encode-time 0 0 0 day month 132 (or year current-year)) 133 state payee)))) 134 (forward-line)))) 135 136 (defcustom ledger-copy-transaction-insert-blank-line-after nil 137 "When non-nil, insert a blank line after `ledger-copy-transaction-at-point'." 138 :type 'boolean 139 :group 'ledger) 140 141 (defun ledger-copy-transaction-at-point (date) 142 "Ask for a new DATE and copy the transaction under point to that date. 143 Leave point on the first amount, if any, otherwise the first account." 144 (interactive (list (ledger-read-date "Copy to date: "))) 145 (let* ((extents (ledger-navigate-find-xact-extents (point))) 146 (transaction (buffer-substring-no-properties (car extents) (cadr extents))) 147 (encoded-date (ledger-parse-iso-date date))) 148 (push-mark) 149 (ledger-xact-find-slot encoded-date) 150 (insert transaction 151 (if (and ledger-copy-transaction-insert-blank-line-after (not (eobp))) 152 "\n\n" 153 "\n")) 154 (beginning-of-line -1) 155 (ledger-navigate-beginning-of-xact) 156 (let ((end (save-excursion (ledger-navigate-end-of-xact) (point)))) 157 (re-search-forward ledger-iso-date-regexp) 158 (replace-match date) 159 (if (ledger-next-amount end) 160 (progn 161 (re-search-forward "[-0-9]") 162 (goto-char (match-beginning 0))) 163 (ledger-next-account end))))) 164 165 (defun ledger-delete-current-transaction (pos) 166 "Delete the transaction surrounding POS." 167 (interactive "d") 168 (let ((bounds (ledger-navigate-find-xact-extents pos))) 169 (delete-region (car bounds) (cadr bounds))) 170 (delete-blank-lines)) 171 172 (defvar ledger-add-transaction-last-date nil 173 "Last date entered using `ledger-read-transaction'.") 174 175 (defun ledger-read-transaction () 176 "Read the text of a transaction, which is at least the current date." 177 (let ((date (ledger-read-date "Date: "))) 178 (concat date " " 179 (when ledger-add-transaction-prompt-for-text 180 (read-string (concat "xact " date ": ") nil 'ledger-minibuffer-history))))) 181 182 (defun ledger-parse-iso-date (date) 183 "Try to parse DATE using `ledger-iso-date-regexp' and return a time value or nil." 184 (save-match-data 185 (when (string-match ledger-iso-date-regexp date) 186 (encode-time 0 0 0 (string-to-number (match-string 4 date)) 187 (string-to-number (match-string 3 date)) 188 (string-to-number (match-string 2 date)))))) 189 190 (defun ledger-add-transaction (transaction-text &optional insert-at-point) 191 "Use ledger xact TRANSACTION-TEXT to add a transaction to the buffer. 192 If INSERT-AT-POINT is non-nil insert the transaction there, 193 otherwise call `ledger-xact-find-slot' to insert it at the 194 correct chronological place in the buffer. 195 196 Interactively, the date is requested via `ledger-read-date' and 197 the \\[universal-argument] enables INSERT-AT-POINT." 198 (interactive (list (ledger-read-transaction) current-prefix-arg)) 199 (let* ((args (with-temp-buffer 200 (insert transaction-text) 201 (eshell-parse-arguments (point-min) (point-max)))) 202 (ledger-buf (current-buffer)) 203 (separator "\n")) 204 (unless insert-at-point 205 (let* ((date (car args)) 206 (parsed-date (ledger-parse-iso-date date))) 207 (setq ledger-add-transaction-last-date parsed-date) 208 (push-mark) 209 ;; TODO: what about when it can't be parsed? 210 (ledger-xact-find-slot (or parsed-date date)) 211 (when (looking-at "\n*\\'") 212 (setq separator "")))) 213 (if (cdr args) 214 (save-excursion 215 (insert 216 (with-temp-buffer 217 (apply #'ledger-exec-ledger ledger-buf (current-buffer) "xact" 218 (mapcar 'eval args)) 219 (goto-char (point-min)) 220 (ledger-post-align-postings (point-min) (point-max)) 221 (buffer-string)) 222 separator)) 223 (insert (car args) " ") 224 (save-excursion (insert "\n" separator))))) 225 226 (provide 'ledger-xact) 227 228 ;;; ledger-xact.el ends here